diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,93 +1,120 @@ -# Mustache library changelog - -## v2.3.2 - -- Added support for GHC 9.0.1 - -## v2.3.0 - -- Changed `EitherT` to `ExceptT` (deprecation) -- removed `getFile` from public API - -## v2.2.3 - -- Quick fix to prevent catchSubstitute from reporting substitutions to the renderer. - -## v2.2.2 - -- Added a function to catch a substitution result - -## v2.2.1 - -- Quickfix for an issue with resolving in context - -## v2.2 - -- changed substitution into a new monad - + easier usage in lambdas and lambdas can now do nested substitution - -## v2.1.4 - -- Treat Null as falsy in sections - -## v2.1.3 - -- Added excaping for the apostrophe "'" as per xml spec, courtesy to @tfausak - -## v2.1.2 - -- Fixed template cache again, as the spec requires access to the previous cache in partials as well - -## v2.1.1 - -- Fixed an error where the substitution of partials would not use the template cache of the new partial - -## v2.1 - -- Added API preserving checked substitution with 'checkedSubstitute' and 'checkedSubstituteValue' -- Better and more ToMustache instances. No longer are all sequences of characters serialised as strings - -## v2.0 - -- Added QuasiQuotes and template Haskell functions for compile time template embedding. - -## v1.0 - -- Stabilised API's - -## v0.5.1.0rc-7 - -- Removed dependency tagsoup -- Added ToMustache instances for some numbers - -## v0.5.0.0rc-6 - -- Removed any dependency on ghc 7.10-type OverlappingInstances -- Resolved String/List overlapping instances - -## v0.4.0.1rc-5 - -- Added a necessary OVERLAPPABLE pragma - -## v0.4.0.0rc-4 (current stable version) - -- Removed `conversion` and `conversion-text` dependency. -- Subsequently removed any dependency on overlapping instances -- Readded support for ghc version 7.8 -- Removed `Char -> Value` instance of `ToMustache` (because of overlap) -- Renamed `AST` - -## v0.3.1.0rc-3 - -- Added infix precedence to conversion operators -- Added `INLINEABLE` pragma to conversion functions - -## v0.3.0.1rc-2 - -Dropped GHC 7.8 support in favor of efficient and easy data conversion. - -## v0.3.0.0rc-1 - -- improved documentation -- fixed a bug with scope -- small interface changes +# Mustache library changelog + +## v2.4.3.1 + +- Renormalize the line endings in `test/unit/examples` (for the + `test-suite unit-tests` stanza) to use the LF convention. + +## v2.4.3 + +- Adds compatibility with `text >= 2.1.2`. + +## v2.4.2 + +- Also treat Null as falsey in inverted sections + +## v2.4.1 + +- Compatibility with `containers >= 0.2.17` + +## v2.4.0 + +- Support for aeson 2 + +## v2.3.2 + +- Added support for GHC 9.0.1 + +## v2.3.0 + +- Changed `EitherT` to `ExceptT` (deprecation) +- removed `getFile` from public API + +## v2.2.3 + +- Quick fix to prevent catchSubstitute from reporting substitutions to the + renderer. + +## v2.2.2 + +- Added a function to catch a substitution result + +## v2.2.1 + +- Quickfix for an issue with resolving in context + +## v2.2 + +- changed substitution into a new monad + + easier usage in lambdas and lambdas can now do nested substitution + +## v2.1.4 + +- Treat Null as falsy in sections + +## v2.1.3 + +- Added excaping for the apostrophe "'" as per xml spec, courtesy to @tfausak + +## v2.1.2 + +- Fixed template cache again, as the spec requires access to the previous cache + in partials as well + +## v2.1.1 + +- Fixed an error where the substitution of partials would not use the template + cache of the new partial + +## v2.1 + +- Added API preserving checked substitution with 'checkedSubstitute' and + 'checkedSubstituteValue' +- Better and more ToMustache instances. No longer are all sequences of + characters serialised as strings + +## v2.0 + +- Added QuasiQuotes and template Haskell functions for compile time template + embedding. + +## v1.0 + +- Stabilised API's + +## v0.5.1.0rc-7 + +- Removed dependency tagsoup +- Added ToMustache instances for some numbers + +## v0.5.0.0rc-6 + +- Removed any dependency on ghc 7.10-type OverlappingInstances +- Resolved String/List overlapping instances + +## v0.4.0.1rc-5 + +- Added a necessary OVERLAPPABLE pragma + +## v0.4.0.0rc-4 (current stable version) + +- Removed `conversion` and `conversion-text` dependency. +- Subsequently removed any dependency on overlapping instances +- Readded support for ghc version 7.8 +- Removed `Char -> Value` instance of `ToMustache` (because of overlap) +- Renamed `AST` + +## v0.3.1.0rc-3 + +- Added infix precedence to conversion operators +- Added `INLINEABLE` pragma to conversion functions + +## v0.3.0.1rc-2 + +- Dropped GHC 7.8 support in favor of efficient and easy data conversion. + +## v0.3.0.0rc-1 + +- improved documentation +- fixed a bug with scope +- small interface changes diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2015, 2016 Justus Adam - -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 Justus Adam nor the names of other - 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 -OWNER 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. +Copyright (c) 2015, 2016 Justus Adam + +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 Justus Adam nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,54 +1,58 @@ -# mustache [![Travis Status](https://travis-ci.org/JustusAdam/mustache.svg?branch=master)](https://travis-ci.org/JustusAdam/mustache) [![Hackage](https://img.shields.io/hackage/v/mustache.svg)](https://hackage.haskell.org/package/mustache) [![Join the chat at https://gitter.im/JustusAdam/mustache](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/JustusAdam/mustache?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) - -Haskell implementation of [mustache templates][mustache-homepage]. - -[mustache-homepage]: https://mustache.github.io - -Implements the official [specs version 1.1.3](https://github.com/mustache/spec/releases/tag/v1.1.3) - -## Motivation - -The old Haskell implementation of mustache templates [hastache][] seemed pretty abandoned to me. This implementation aims to be much easier to use and (fingers crossed) better maintained. - -[hastache]: https://hackage.haskell.org/package/hastache - -Since it is so easy to use and requires but a few files of code, I've also written a small executable that compiles and renders mustache templates with data input from json or yaml files. - -## Usage - -### Library - -Please refer to the [documentation][] on hackage. - -[documentation]: https://hackage.haskell.org/package/mustache - -### Executable `haskell-mustache` - - $ haskell-mustache --help - Simple mustache template substitution - - arguments [OPTIONS] TEMPLATE [DATA-FILES] - - Common flags: - -t --templatedirs[=DIRECTORY] The directory in which to search for the - templates - -? --help Display help message - -V --version Print version information - -Current implementation substitutes the `TEMPLATE` once with each `DATA-FILE` - -#### Example - - $ haskell-mustache my-template-file data-file-1.json data-file-2.json data-file-3.json - -## Roadmap - -- [x] String parser for mustache templates -- [x] Template substitution -- [x] Standalone executable -- [x] Support for 'set delimiter' -- [x] More efficiency using `Text` rather than `String` -- [x] More efficient Text parsing -- [x] Test coverage provided via the official [specs](https://github.com/mustache/spec) -- [x] Haddock documentation -- [ ] More instances for `ToMustache` typeclass +# mustache + +![Build Status](https://github.com/JustusAdam/mustache/actions/workflows/build.yml/badge.svg) +[![Hackage](https://img.shields.io/hackage/v/mustache.svg)](https://hackage.haskell.org/package/mustache) +[![Join the chat at https://gitter.im/JustusAdam/mustache](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/JustusAdam/mustache?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) + +Haskell implementation of [mustache templates][mustache-homepage]. + +[mustache-homepage]: https://mustache.github.io + +Implements the official [specs version 1.1.3](https://github.com/mustache/spec/releases/tag/v1.1.3) + +## Motivation + +The old Haskell implementation of mustache templates [hastache][] seemed pretty abandoned to me. This implementation aims to be much easier to use and (fingers crossed) better maintained. + +[hastache]: https://hackage.haskell.org/package/hastache + +Since it is so easy to use and requires but a few files of code, I've also written a small executable that compiles and renders mustache templates with data input from json or yaml files. + +## Usage + +### Library + +Please refer to the [documentation][] on hackage. + +[documentation]: https://hackage.haskell.org/package/mustache + +### Executable `haskell-mustache` + + $ haskell-mustache --help + Simple mustache template substitution + + arguments [OPTIONS] TEMPLATE [DATA-FILES] + + Common flags: + -t --templatedirs[=DIRECTORY] The directory in which to search for the + templates + -? --help Display help message + -V --version Print version information + +Current implementation substitutes the `TEMPLATE` once with each `DATA-FILE` + +#### Example + + $ haskell-mustache my-template-file data-file-1.json data-file-2.json data-file-3.json + +## Roadmap + +- [x] String parser for mustache templates +- [x] Template substitution +- [x] Standalone executable +- [x] Support for 'set delimiter' +- [x] More efficiency using `Text` rather than `String` +- [x] More efficient Text parsing +- [x] Test coverage provided via the official [specs](https://github.com/mustache/spec) +- [x] Haddock documentation +- [ ] More instances for `ToMustache` typeclass diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,72 +1,72 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NamedFieldPuns #-} -module Main (main) where - - -import Data.Aeson (Value, eitherDecode) -import Data.Bifunctor (first) -import qualified Data.ByteString as B (readFile) -import qualified Data.ByteString.Lazy as BS (readFile) -import Data.Foldable (for_) -import qualified Data.Text.IO as TIO (putStrLn) -import Data.Yaml (decodeEither') - -import System.Console.CmdArgs.Implicit (Data, Typeable, argPos, args, - cmdArgs, def, help, summary, - typ, (&=)) -import System.FilePath (takeExtension) -import Text.Mustache (automaticCompile, substitute, - toMustache) - - -data Arguments = Arguments - { template :: FilePath - , templateDirs :: [FilePath] - , dataFiles :: [FilePath] - } deriving (Show, Data, Typeable) - - -commandArgs :: Arguments -commandArgs = Arguments - { template = def - &= argPos 0 - &= typ "TEMPLATE" - , dataFiles = def - &= args - &= typ "DATA-FILES" - , templateDirs = ["."] - &= help "The directories in which to search for the templates" - &= typ "DIRECTORIES" - } &= summary "Simple mustache template subtitution" - - -readJSON :: FilePath -> IO (Either String Value) -readJSON = fmap eitherDecode . BS.readFile - - -readYAML :: FilePath -> IO (Either String Value) -readYAML = fmap (first show . decodeEither') . B.readFile - - -main :: IO () -main = do - (Arguments { template, templateDirs, dataFiles }) <- cmdArgs commandArgs - - eitherTemplate <- automaticCompile templateDirs template - - case eitherTemplate of - Left err -> print err - Right compiledTemplate -> - for_ dataFiles $ \file -> do - - let decoder = - case takeExtension file of - ".yml" -> readYAML - ".yaml" -> readYAML - _ -> readJSON - decoded <- decoder file - - either - putStrLn - (TIO.putStrLn . substitute compiledTemplate . toMustache) - decoded +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +module Main (main) where + + +import Data.Aeson (Value, eitherDecode) +import Data.Bifunctor (first) +import qualified Data.ByteString as B (readFile) +import qualified Data.ByteString.Lazy as BS (readFile) +import Data.Foldable (for_) +import qualified Data.Text.IO as TIO (putStrLn) +import Data.Yaml (decodeEither') + +import System.Console.CmdArgs.Implicit (Data, Typeable, argPos, args, + cmdArgs, def, help, summary, + typ, (&=)) +import System.FilePath (takeExtension) +import Text.Mustache (automaticCompile, substitute, + toMustache) + + +data Arguments = Arguments + { template :: FilePath + , templateDirs :: [FilePath] + , dataFiles :: [FilePath] + } deriving (Show, Data, Typeable) + + +commandArgs :: Arguments +commandArgs = Arguments + { template = def + &= argPos 0 + &= typ "TEMPLATE" + , dataFiles = def + &= args + &= typ "DATA-FILES" + , templateDirs = ["."] + &= help "The directories in which to search for the templates" + &= typ "DIRECTORIES" + } &= summary "Simple mustache template subtitution" + + +readJSON :: FilePath -> IO (Either String Value) +readJSON = fmap eitherDecode . BS.readFile + + +readYAML :: FilePath -> IO (Either String Value) +readYAML = fmap (first show . decodeEither') . B.readFile + + +main :: IO () +main = do + (Arguments { template, templateDirs, dataFiles }) <- cmdArgs commandArgs + + eitherTemplate <- automaticCompile templateDirs template + + case eitherTemplate of + Left err -> print err + Right compiledTemplate -> + for_ dataFiles $ \file -> do + + let decoder = + case takeExtension file of + ".yml" -> readYAML + ".yaml" -> readYAML + _ -> readJSON + decoded <- decoder file + + either + putStrLn + (TIO.putStrLn . substitute compiledTemplate . toMustache) + decoded diff --git a/mustache.cabal b/mustache.cabal --- a/mustache.cabal +++ b/mustache.cabal @@ -1,141 +1,132 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack - -name: mustache -version: 2.3.2 -synopsis: A mustache template parser library. -description: Allows parsing and rendering template files with mustache markup. See the - mustache . - . - Implements the mustache spec version 1.1.3. - . - /Note/: Versions including and beyond 0.4 are compatible with ghc 7.8 again. -category: Development -homepage: https://github.com/JustusAdam/mustache -bug-reports: https://github.com/JustusAdam/mustache/issues -author: Justus Adam -maintainer: dev@justus.science -copyright: (c) 2015 - 2019 Justus Adam -license: BSD3 -license-file: LICENSE -build-type: Simple -tested-with: - GHC>=7.8 && <=7.10.2 -extra-source-files: - README.md - CHANGELOG.md - test/unit/examples/test-template-partials.txt.mustache - test/unit/examples/test-template.txt.mustache - test/unit/examples/partials/test-partial.txt.mustache - -source-repository head - type: git - location: git://github.com/JustusAdam/mustache.git - -library - exposed-modules: - Text.Mustache - Text.Mustache.Types - Text.Mustache.Parser - Text.Mustache.Compile - Text.Mustache.Render - other-modules: - Text.Mustache.Internal - Text.Mustache.Internal.Types - Paths_mustache - hs-source-dirs: - src - default-extensions: - LambdaCase - TupleSections - other-extensions: - NamedFieldPuns - OverloadedStrings - LambdaCase - TupleSections - TemplateHaskell - QuasiQuotes - ghc-options: -Wall - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , containers - , directory - , filepath - , mtl >=2.2.1 - , parsec - , scientific - , template-haskell - , text - , th-lift - , unordered-containers - , vector - default-language: Haskell2010 - -executable haskell-mustache - main-is: Main.hs - other-modules: - Paths_mustache - hs-source-dirs: - app - ghc-options: -threaded -Wall - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , cmdargs - , filepath - , mustache - , text - , yaml - default-language: Haskell2010 - -test-suite language-specifications - type: exitcode-stdio-1.0 - main-is: Language.hs - other-modules: - Paths_mustache - hs-source-dirs: - test/integration - build-depends: - aeson - , base >=4.7 && <5 - , base-unicode-symbols - , bytestring - , filepath - , hspec - , lens - , mustache - , tar - , text - , unordered-containers - , wreq - , yaml - , zlib - default-language: Haskell2010 - -test-suite unit-tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_mustache - hs-source-dirs: - test/unit - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , directory - , filepath - , hspec - , mustache - , process - , temporary - , text - , unordered-containers - , yaml - default-language: Haskell2010 +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: mustache +version: 2.4.3.1 +synopsis: A mustache template parser library. +description: Allows parsing and rendering template files with mustache markup. See the + mustache . + . + Implements the mustache spec version 1.1.3. + . + /Note/: Versions including and beyond 0.4 are compatible with ghc 7.8 again. +category: Development +homepage: https://github.com/JustusAdam/mustache#readme +bug-reports: https://github.com/JustusAdam/mustache/issues +author: Justus Adam +maintainer: dev@justus.science +copyright: (c) 2015 - 2022 Justus Adam +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + test/unit/examples/test-template-partials.txt.mustache + test/unit/examples/test-template.txt.mustache + test/unit/examples/partials/test-partial.txt.mustache + +source-repository head + type: git + location: https://github.com/JustusAdam/mustache + +library + exposed-modules: + Text.Mustache + Text.Mustache.Compile + Text.Mustache.Parser + Text.Mustache.Render + Text.Mustache.Types + other-modules: + Text.Mustache.Internal + Text.Mustache.Internal.Types + hs-source-dirs: + src + default-extensions: + LambdaCase + TupleSections + other-extensions: + LambdaCase + NamedFieldPuns + OverloadedStrings + QuasiQuotes + TemplateHaskell + TupleSections + ghc-options: -Wall + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , directory + , filepath + , mtl >=2.2.1 + , parsec + , scientific + , template-haskell + , text + , th-lift + , unordered-containers + , vector + default-language: Haskell2010 + +executable haskell-mustache + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -threaded -Wall + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , cmdargs + , filepath + , mustache + , text + , yaml + default-language: Haskell2010 + +test-suite language-specifications + type: exitcode-stdio-1.0 + main-is: Language.hs + hs-source-dirs: + test/integration + build-depends: + aeson + , base >=4.7 && <5 + , base-unicode-symbols + , bytestring + , filepath + , hspec + , lens + , mustache + , tar + , text + , unordered-containers + , wreq + , yaml + , zlib + default-language: Haskell2010 + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test/unit + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , directory + , filepath + , hspec + , mustache + , process + , temporary + , text + , unordered-containers + , yaml + default-language: Haskell2010 diff --git a/src/Text/Mustache.hs b/src/Text/Mustache.hs --- a/src/Text/Mustache.hs +++ b/src/Text/Mustache.hs @@ -1,197 +1,204 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX - -= How to use this library - -This module exposes some of the most convenient functions for dealing with mustache -templates. - -== Compiling with automatic partial discovery - -The easiest way of compiling a file and its potential includes (called partials) -is by using the 'automaticCompile' function. - -@ -main :: IO () -main = do - let searchSpace = [".", "./templates"] - templateName = "main.mustache" - - compiled <- automaticCompile searchSpace templateName - case compiled of - Left err -> print err - Right template -> return () -- this is where you can start using it -@ - -The @searchSpace@ encompasses all directories in which the compiler should -search for the template source files. -The search itself is conducted in order, from left to right. - -Should your search space be only the current working directory, you can use -'localAutomaticCompile'. - -The @templateName@ is the relative path of the template to any directory -of the search space. - -'automaticCompile' not only finds and compiles the template for you, it also -recursively finds any partials included in the template as well, -compiles them and stores them in the 'partials' hash attached to the resulting -template. - -The compiler will throw errors if either the template is malformed -or the source file for a partial or the template itself could not be found -in any of the directories in @searchSpace@. - -== Substituting - -In order to substitute data into the template it must be an instance of the 'ToMustache' -typeclass or be of type 'Value'. - -This libray tries to imitate the API of -by allowing you to define conversions of your own custom data types into 'Value', -the type used internally by the substitutor via typeclass and a selection of -operators and convenience functions. - -=== Example - -@ - data Person = { age :: Int, name :: String } - - instance ToMustache Person where - toMustache person = object - [ "age" ~> age person - , "name" ~> name person - ] -@ - -The values to the left of the '~>' operator has to be of type 'Text', hence the -@OverloadedStrings@ can becomes very handy here. - -Values to the right of the '~>' operator must be an instance of the 'ToMustache' -typeclass. Alternatively, if your value to the right of the '~>' operator is -not an instance of 'ToMustache' but an instance of 'ToJSON' you can use the -'~=' operator, which accepts 'ToJSON' values. - -@ - data Person = { age :: Int, name :: String, address :: Address } - - data Address = ... - - instance ToJSON Address where - ... - - instance ToMustache Person where - toMustache person = object - [ "age" ~> age person - , "name" ~> name person - , "address" ~= address person - ] -@ - -All operators are also provided in a unicode form, for those that, like me, enjoy -unicode operators. - -== Manual compiling - -You can compile templates manually without requiring the IO monad at all, using -the 'compileTemplate' function. This is the same function internally used by -'automaticCompile' and does not check if required partial are present. - -More functions for manual compilation can be found in the 'Text.Mustache.Compile' -module. Including helpers for finding lists of partials in templates. - -Additionally the 'compileTemplateWithCache' function is exposed here which you -may use to automatically compile a template but avoid some of the compilation -overhead by providing already compiled partials as well. - -== Fundamentals - -This library builds on three important data structures/types. - -['Value'] A data structure almost identical to Data.Aeson.Value extended with -lambda functions which represents the data the template is being filled with. - -['ToMustache'] A typeclass for converting arbitrary types to 'Value', similar -to Data.Aeson.ToJSON but with support for lambdas. - -['Template'] Contains the 'STree', the syntax tree, which is basically a -list of text blocks and mustache tags. The 'name' of the template and its -'partials' cache. - -=== Compiling - -During the compilation step the template file is located, read, then parsed in a single -pass ('compileTemplate'), resulting in a 'Template' with an empty 'partials' section. - -Subsequenty the 'STree' of the template is scanned for included partials, any -present 'TemplateCache' is queried for the partial ('compileTemplateWithCache'), -if not found it will be searched for in the @searchSpace@, compiled and -inserted into the template's own cache as well as the global cache for the -compilation process. - -Internally no partial is compiled twice, as long as the names stay consistent. - -Once compiled templates may be used multiple times for substitution or as -partial for other templates. - -Partials are not being embedded into the templates during compilation, but during -substitution, hence the 'partials' cache is vital to the template even after -compilation has been completed. Any non existent partial in the cache will -rsubstitute to an empty string. - -=== Substituting - - - --} -{-# LANGUAGE LambdaCase #-} -module Text.Mustache - ( - -- * Compiling - - -- ** Automatic - automaticCompile, localAutomaticCompile - - -- ** Manually - , compileTemplateWithCache, compileTemplate, Template(..) - - -- * Rendering - - -- ** Generic - - , substitute, checkedSubstitute - - -- ** Specialized - - , substituteValue, checkedSubstituteValue - - -- ** In Lambdas - - , substituteNode, substituteAST, catchSubstitute - - -- * Data Conversion - , ToMustache, toMustache, integralToMustache, object, (~>), (~=) - - -- ** Utilities for lambdas - - , overText - - ) where - - - -import Text.Mustache.Compile -import Text.Mustache.Render -import Text.Mustache.Types -import qualified Data.Text as T - - --- | Creates a 'Lambda' which first renders the contained section and then applies the supplied function -overText :: (T.Text -> T.Text) -> Value -overText f = toMustache $ fmap (f . snd) . catchSubstitute . substituteAST +{-| +Module : $Header$ +Description : Basic functions for dealing with mustache templates. +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX + += How to use this library + +This module exposes some of the most convenient functions for dealing with mustache +templates. + +== Compiling with automatic partial discovery + +The easiest way of compiling a file and its potential includes (called partials) +is by using the 'automaticCompile' function. + +@ +main :: IO () +main = do + let searchSpace = [".", "./templates"] + templateName = "main.mustache" + + compiled <- automaticCompile searchSpace templateName + case compiled of + Left err -> print err + Right template -> pure () -- this is where you can start using it +@ + +The @searchSpace@ encompasses all directories in which the compiler should +search for the template source files. +The search itself is conducted in order, from left to right. + +Should your search space be only the current working directory, you can use +'localAutomaticCompile'. + +The @templateName@ is the relative path of the template to any directory +of the search space. + +'automaticCompile' not only finds and compiles the template for you, it also +recursively finds any partials included in the template as well, +compiles them and stores them in the 'partials' hash attached to the resulting +template. + +The compiler will throw errors if either the template is malformed +or the source file for a partial or the template itself could not be found +in any of the directories in @searchSpace@. + +== Substituting + +In order to substitute data into the template it must be an instance of the 'ToMustache' +typeclass or be of type 'Value'. + +This libray tries to imitate the API of +by allowing you to define conversions of your own custom data types into 'Value', +the type used internally by the substitutor via typeclass and a selection of +operators and convenience functions. + +=== Example + +@ + data Person = { age :: Int, name :: String } + + instance ToMustache Person where + toMustache person = object + [ "age" ~> age person + , "name" ~> name person + ] +@ + +The values to the left of the '~>' operator has to be of type 'Text', hence the +@OverloadedStrings@ can becomes very handy here. + +Values to the right of the '~>' operator must be an instance of the 'ToMustache' +typeclass. Alternatively, if your value to the right of the '~>' operator is +not an instance of 'ToMustache' but an instance of 'ToJSON' you can use the +'~=' operator, which accepts 'ToJSON' values. + +@ + data Person = { age :: Int, name :: String, address :: Address } + + data Address = ... + + instance ToJSON Address where + ... + + instance ToMustache Person where + toMustache person = object + [ "age" ~> age person + , "name" ~> name person + , "address" ~= address person + ] +@ + +All operators are also provided in a unicode form, for those that, like me, enjoy +unicode operators. + +== Manual compiling + +You can compile templates manually without requiring the IO monad at all, using +the 'compileTemplate' function. This is the same function internally used by +'automaticCompile' and does not check if required partial are present. + +More functions for manual compilation can be found in the 'Text.Mustache.Compile' +module. Including helpers for finding lists of partials in templates. + +Additionally the 'compileTemplateWithCache' function is exposed here which you +may use to automatically compile a template but avoid some of the compilation +overhead by providing already compiled partials as well. + +== Fundamentals + +This library builds on three important data structures/types. + +['Value'] A data structure almost identical to Data.Aeson.Value extended with +lambda functions which represents the data the template is being filled with. + +['ToMustache'] A typeclass for converting arbitrary types to 'Value', similar +to Data.Aeson.ToJSON but with support for lambdas. + +['Template'] Contains the 'STree', the syntax tree, which is basically a +list of text blocks and mustache tags. The 'name' of the template and its +'partials' cache. + +=== Compiling + +During the compilation step the template file is located, read, then parsed in a single +pass ('compileTemplate'), resulting in a 'Template' with an empty 'partials' section. + +Subsequenty the 'STree' of the template is scanned for included partials, any +present 'TemplateCache' is queried for the partial ('compileTemplateWithCache'), +if not found it will be searched for in the @searchSpace@, compiled and +inserted into the template's own cache as well as the global cache for the +compilation process. + +Internally no partial is compiled twice, as long as the names stay consistent. + +Once compiled templates may be used multiple times for substitution or as +partial for other templates. + +Partials are not being embedded into the templates during compilation, but during +substitution, hence the 'partials' cache is vital to the template even after +compilation has been completed. Any non existent partial in the cache will +rsubstitute to an empty string. + +=== Substituting + + + +-} +module Text.Mustache + ( + -- * Compiling + -- ** Automatic + automaticCompile + , localAutomaticCompile + -- ** Manually + , compileTemplateWithCache + , compileTemplate + , Template (..) + -- * Rendering + -- ** Generic + , substitute + , checkedSubstitute + -- ** Specialized + , substituteValue + , checkedSubstituteValue + -- ** In Lambdas + , substituteNode + , substituteAST + , catchSubstitute + -- * Data Conversion + , ToMustache + , toMustache + , integralToMustache + , object + , (~>) + , (~=) + -- ** Utilities for lambdas + , overText + ) where + + +import qualified Data.Text as T +import Text.Mustache.Compile + ( automaticCompile, compileTemplate, compileTemplateWithCache + , localAutomaticCompile + ) +import Text.Mustache.Render + ( catchSubstitute, checkedSubstitute, checkedSubstituteValue + , substitute, substituteAST, substituteNode, substituteValue + ) +import Text.Mustache.Types + ( Template (..), ToMustache (..), Value, (~>), (~=) + , integralToMustache, object + ) + + +-- | Creates a 'Lambda' which first renders the contained section and then +-- applies the supplied function +overText :: (T.Text -> T.Text) -> Value +overText f = toMustache $ fmap (f . snd) . catchSubstitute . substituteAST diff --git a/src/Text/Mustache/Compile.hs b/src/Text/Mustache/Compile.hs --- a/src/Text/Mustache/Compile.hs +++ b/src/Text/Mustache/Compile.hs @@ -1,213 +1,234 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module Text.Mustache.Compile - ( automaticCompile, localAutomaticCompile, TemplateCache, compileTemplateWithCache - , compileTemplate, cacheFromList, getPartials, mustache, embedTemplate, embedSingleTemplate - ) where - - -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Except -import Control.Monad.State -import Data.Bool -import Data.HashMap.Strict as HM -import Data.Text hiding (concat, find, map, uncons) -import qualified Data.Text.IO as TIO -import Language.Haskell.TH (Exp, Loc, Q, loc_filename, - loc_start, location) -import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), - quoteExp) -import qualified Language.Haskell.TH.Syntax as THS -import System.Directory -import System.FilePath -import Text.Mustache.Parser -import Text.Mustache.Types -import Text.Parsec.Error -import Text.Parsec.Pos -import Text.Printf - -{-| - Compiles a mustache template provided by name including the mentioned partials. - - The same can be done manually using 'getFile', 'mustacheParser' and 'getPartials'. - - This function also ensures each partial is only compiled once even though it may - be included by other partials including itself. - - A reference to the included template will be found in each including templates - 'partials' section. --} -automaticCompile :: [FilePath] -> FilePath -> IO (Either ParseError Template) -automaticCompile searchSpace = compileTemplateWithCache searchSpace mempty - - --- | Compile the template with the search space set to only the current directory -localAutomaticCompile :: FilePath -> IO (Either ParseError Template) -localAutomaticCompile = automaticCompile ["."] - - -{-| - Compile a mustache template providing a list of precompiled templates that do - not have to be recompiled. --} -compileTemplateWithCache :: [FilePath] - -> TemplateCache - -> FilePath - -> IO (Either ParseError Template) -compileTemplateWithCache searchSpace templates initName = - runExceptT $ evalStateT (compile' initName) $ flattenPartials templates - where - compile' :: FilePath - -> StateT - (HM.HashMap String Template) - (ExceptT ParseError IO) - Template - compile' name' = do - templates' <- get - case HM.lookup name' templates' of - Just template -> return template - Nothing -> do - rawSource <- lift $ getFile searchSpace name' - compiled@(Template { ast = mSTree }) <- - lift $ ExceptT . pure $ compileTemplate name' rawSource - - foldM - (\st@(Template { partials = p }) partialName -> do - nt <- compile' partialName - modify (HM.insert partialName nt) - return (st { partials = HM.insert partialName nt p }) - ) - compiled - (getPartials mSTree) - - --- | Flatten a list of Templates into a single 'TemplateCache' -cacheFromList :: [Template] -> TemplateCache -cacheFromList = flattenPartials . fromList . fmap (name &&& id) - - --- | Compiles a 'Template' directly from 'Text' without checking for missing partials. --- the result will be a 'Template' with an empty 'partials' cache. -compileTemplate :: String -> Text -> Either ParseError Template -compileTemplate name' = fmap (flip (Template name') mempty) . parse name' - - -{-| - Find the names of all included partials in a mustache STree. - - Same as @join . fmap getPartials'@ --} -getPartials :: STree -> [FilePath] -getPartials = join . fmap getPartials' - - -{-| - Find partials in a single Node --} -getPartials' :: Node Text -> [FilePath] -getPartials' (Partial _ p) = return p -getPartials' (Section _ n) = getPartials n -getPartials' (InvertedSection _ n) = getPartials n -getPartials' _ = mempty - - -flattenPartials :: TemplateCache -> TemplateCache -flattenPartials m = foldrWithKey (insertWith (\_ b -> b)) m m - - -{-| - @getFile searchSpace file@ iteratively searches all directories in - @searchSpace@ for a @file@ returning it if found or raising an error if none - of the directories contain the file. - - This trows 'ParseError's to be compatible with the internal Either Monad of - 'compileTemplateWithCache'. --} -getFile :: [FilePath] -> FilePath -> ExceptT ParseError IO Text -getFile [] fp = throwError $ fileNotFound fp -getFile (templateDir : xs) fp = - lift (doesFileExist filePath) >>= - bool - (getFile xs fp) - (lift $ TIO.readFile filePath) - where - filePath = templateDir fp - - --- | --- Compile a mustache 'Template' at compile time. Usage: --- --- > {-# LANGUAGE QuasiQuotes #-} --- > import Text.Mustache.Compile (mustache) --- > --- > foo :: Template --- > foo = [mustache|This is my inline {{ template }} created at compile time|] --- --- Partials are not supported in the QuasiQuoter - -mustache :: QuasiQuoter -mustache = QuasiQuoter {quoteExp = \unprocessedTemplate -> do - l <- location - compileTemplateTH (fileAndLine l) unprocessedTemplate } - --- | --- Compile a mustache 'Template' at compile time providing a search space for any partials. Usage: --- --- > {-# LANGUAGE TemplateHaskell #-} --- > import Text.Mustache.Compile (embedTemplate) --- > --- > foo :: Template --- > foo = $(embedTemplate ["dir", "dir/partials"] "file.mustache") --- - -embedTemplate :: [FilePath] -> FilePath -> Q Exp -embedTemplate searchSpace filename = do - template <- either (fail . ("Parse error in mustache template: " ++) . show) pure =<< THS.runIO (automaticCompile searchSpace filename) - let possiblePaths = do - fname <- (filename:) . HM.keys . partials $ template - path <- searchSpace - pure $ path fname - mapM_ addDependentRelativeFile =<< THS.runIO (filterM doesFileExist possiblePaths) - THS.lift template - --- | --- Compile a mustache 'Template' at compile time. Usage: --- --- > {-# LANGUAGE TemplateHaskell #-} --- > import Text.Mustache.Compile (embedSingleTemplate) --- > --- > foo :: Template --- > foo = $(embedSingleTemplate "dir/file.mustache") --- --- Partials are not supported in embedSingleTemplate - -embedSingleTemplate :: FilePath -> Q Exp -embedSingleTemplate filePath = do - addDependentRelativeFile filePath - compileTemplateTH filePath =<< THS.runIO (readFile filePath) - -fileAndLine :: Loc -> String -fileAndLine loc = loc_filename loc ++ ":" ++ (show . fst . loc_start $ loc) - -compileTemplateTH :: String -> String -> Q Exp -compileTemplateTH filename unprocessed = - either (fail . ("Parse error in mustache template: " ++) . show) THS.lift $ compileTemplate filename (pack unprocessed) - -addDependentRelativeFile :: FilePath -> Q () -addDependentRelativeFile = THS.qAddDependentFile <=< THS.runIO . makeAbsolute - --- ERRORS - -fileNotFound :: FilePath -> ParseError -fileNotFound fp = newErrorMessage (Message $ printf "Template file '%s' not found" fp) (initialPos fp) +{-| +Module : $Header$ +Description : Basic functions for dealing with mustache templates. +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module Text.Mustache.Compile + ( automaticCompile + , localAutomaticCompile + , TemplateCache + , compileTemplateWithCache + , compileTemplate + , cacheFromList + , getPartials + , mustache + , embedTemplate + , embedSingleTemplate + ) where + + +import Control.Arrow ( (&&&) ) +import Control.Monad ( (<=<), filterM, foldM ) +import Control.Monad.Except + ( ExceptT (..), MonadError (..), runExceptT ) +import Control.Monad.State + ( MonadState (..), MonadTrans (..), StateT, evalStateT + , modify + ) +import Data.Bool ( bool ) +import qualified Data.HashMap.Strict as HM +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Language.Haskell.TH + ( Exp, Loc, Q, loc_filename, loc_start, location ) +import Language.Haskell.TH.Quote + ( QuasiQuoter (..), quoteExp ) +import qualified Language.Haskell.TH.Syntax as THS +import System.Directory ( doesFileExist, makeAbsolute ) +import System.FilePath ( () ) +import Text.Mustache.Parser ( parse ) +import Text.Mustache.Types + ( STree, Template (..), TemplateCache, Node (..) ) +import Text.Parsec.Error ( Message (..), ParseError, newErrorMessage ) +import Text.Parsec.Pos ( initialPos ) +import Text.Printf ( printf ) + + +{-| + Compiles a mustache template provided by name including the mentioned partials. + + The same can be done manually using 'getFile', 'mustacheParser' and 'getPartials'. + + This function also ensures each partial is only compiled once even though it may + be included by other partials including itself. + + A reference to the included template will be found in each including templates + 'partials' section. +-} +automaticCompile :: [FilePath] -> FilePath -> IO (Either ParseError Template) +automaticCompile searchSpace = compileTemplateWithCache searchSpace mempty + + +-- | Compile the template with the search space set to only the current directory +localAutomaticCompile :: FilePath -> IO (Either ParseError Template) +localAutomaticCompile = automaticCompile ["."] + + +{-| + Compile a mustache template providing a list of precompiled templates that do + not have to be recompiled. +-} +compileTemplateWithCache :: [FilePath] + -> TemplateCache + -> FilePath + -> IO (Either ParseError Template) +compileTemplateWithCache searchSpace templates initName = + runExceptT $ evalStateT (compile' initName) $ flattenPartials templates + where + compile' :: FilePath + -> StateT + (HM.HashMap String Template) + (ExceptT ParseError IO) + Template + compile' name' = do + templates' <- get + case HM.lookup name' templates' of + Just template -> pure template + Nothing -> do + rawSource <- lift $ getFile searchSpace name' + compiled@(Template { ast = mSTree }) <- + lift $ ExceptT . pure $ compileTemplate name' rawSource + + foldM + (\st@(Template { partials = p }) partialName -> do + nt <- compile' partialName + modify (HM.insert partialName nt) + pure (st { partials = HM.insert partialName nt p }) + ) + compiled + (getPartials mSTree) + + +-- | Flatten a list of Templates into a single 'TemplateCache' +cacheFromList :: [Template] -> TemplateCache +cacheFromList = flattenPartials . HM.fromList . fmap (name &&& id) + + +-- | Compiles a 'Template' directly from 'Text' without checking for missing partials. +-- the result will be a 'Template' with an empty 'partials' cache. +compileTemplate :: String -> Text -> Either ParseError Template +compileTemplate name' = fmap (flip (Template name') mempty) . parse name' + + +{-| + Find the names of all included partials in a mustache STree. + + Same as @join . fmap getPartials'@ +-} +getPartials :: STree -> [FilePath] +getPartials = (getPartials' =<<) + + +{-| + Find partials in a single Node +-} +getPartials' :: Node Text -> [FilePath] +getPartials' (Partial _ p) = pure p +getPartials' (Section _ n) = getPartials n +getPartials' (InvertedSection _ n) = getPartials n +getPartials' _ = mempty + + +flattenPartials :: TemplateCache -> TemplateCache +flattenPartials m = HM.foldrWithKey (HM.insertWith (\_ b -> b)) m m + + +{-| + @getFile searchSpace file@ iteratively searches all directories in + @searchSpace@ for a @file@ returning it if found or raising an error if none + of the directories contain the file. + + This trows 'ParseError's to be compatible with the internal Either Monad of + 'compileTemplateWithCache'. +-} +getFile :: [FilePath] -> FilePath -> ExceptT ParseError IO Text +getFile [] fp = throwError $ fileNotFound fp +getFile (templateDir : xs) fp = + lift (doesFileExist filePath) >>= + bool + (getFile xs fp) + (lift $ TIO.readFile filePath) + where + filePath = templateDir fp + + +-- | +-- Compile a mustache 'Template' at compile time. Usage: +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > import Text.Mustache.Compile (mustache) +-- > +-- > foo :: Template +-- > foo = [mustache|This is my inline {{ template }} created at compile time|] +-- +-- Partials are not supported in the QuasiQuoter +mustache :: QuasiQuoter +mustache = QuasiQuoter {quoteExp = \unprocessedTemplate -> do + l <- location + compileTemplateTH (fileAndLine l) unprocessedTemplate } + + +-- | +-- Compile a mustache 'Template' at compile time providing a search space for +-- any partials. Usage: +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > import Text.Mustache.Compile (embedTemplate) +-- > +-- > foo :: Template +-- > foo = $(embedTemplate ["dir", "dir/partials"] "file.mustache") +-- +embedTemplate :: [FilePath] -> FilePath -> Q Exp +embedTemplate searchSpace filename = do + template <- either (fail . ("Parse error in mustache template: " ++) . show) pure =<< THS.runIO (automaticCompile searchSpace filename) + let possiblePaths = do + fname <- (filename:) . HM.keys . partials $ template + path <- searchSpace + pure $ path fname + mapM_ addDependentRelativeFile =<< THS.runIO (filterM doesFileExist possiblePaths) + THS.lift template + + +-- | +-- Compile a mustache 'Template' at compile time. Usage: +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > import Text.Mustache.Compile (embedSingleTemplate) +-- > +-- > foo :: Template +-- > foo = $(embedSingleTemplate "dir/file.mustache") +-- +-- Partials are not supported in embedSingleTemplate +embedSingleTemplate :: FilePath -> Q Exp +embedSingleTemplate filePath = do + addDependentRelativeFile filePath + compileTemplateTH filePath =<< THS.runIO (readFile filePath) + + +fileAndLine :: Loc -> String +fileAndLine loc = loc_filename loc ++ ":" ++ (show . fst . loc_start $ loc) + + +compileTemplateTH :: String -> String -> Q Exp +compileTemplateTH filename unprocessed = + either + (fail . ("Parse error in mustache template: " ++) . show) + THS.lift + (compileTemplate filename (T.pack unprocessed)) + + +addDependentRelativeFile :: FilePath -> Q () +addDependentRelativeFile = THS.qAddDependentFile <=< THS.runIO . makeAbsolute + + +-- ERRORS +fileNotFound :: FilePath -> ParseError +fileNotFound fp = newErrorMessage + (Message $ printf "Template file '%s' not found" fp) + (initialPos fp) diff --git a/src/Text/Mustache/Internal.hs b/src/Text/Mustache/Internal.hs --- a/src/Text/Mustache/Internal.hs +++ b/src/Text/Mustache/Internal.hs @@ -1,41 +1,44 @@ -{-| -Module : $Header$ -Description : Types and conversions -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX - -escapeXML and xmlEntities curtesy to the tagsoup library. --} -module Text.Mustache.Internal (uncons, escapeXMLText) where - - -import Data.Char (ord) -import qualified Data.IntMap as IntMap -import qualified Data.Text as T - - -uncons :: [α] -> Maybe (α, [α]) -uncons [] = Nothing -uncons (x:xs) = return (x, xs) - - -escapeXMLText :: T.Text -> T.Text -escapeXMLText = T.pack . escapeXML . T.unpack - - -escapeXML :: String -> String -escapeXML = concatMap $ \x -> IntMap.findWithDefault [x] (ord x) mp - where mp = IntMap.fromList [(ord b, "&"++a++";") | (a,[b]) <- xmlEntities] - - -xmlEntities :: [(String, String)] -xmlEntities = - [ ("quot", "\"") - , ("#39", "'") - , ("amp" , "&") - , ("lt" , "<") - , ("gt" , ">") - ] +{-| +Module : $Header$ +Description : Types and conversions +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX + +escapeXML and xmlEntities curtesy to the tagsoup library. +-} +module Text.Mustache.Internal + ( uncons + , escapeXMLText + ) where + + +import Data.Char ( ord ) +import qualified Data.IntMap as IntMap +import qualified Data.Text as T + + +uncons :: [α] -> Maybe (α, [α]) +uncons [] = Nothing +uncons (x:xs) = pure (x, xs) + + +escapeXMLText :: T.Text -> T.Text +escapeXMLText = T.pack . escapeXML . T.unpack + + +escapeXML :: String -> String +escapeXML = concatMap $ \x -> IntMap.findWithDefault [x] (ord x) mp + where mp = IntMap.fromList [(ord b, "&"++a++";") | (a,[b]) <- xmlEntities] + + +xmlEntities :: [(String, String)] +xmlEntities = + [ ("quot", "\"") + , ("#39", "'") + , ("amp" , "&") + , ("lt" , "<") + , ("gt" , ">") + ] diff --git a/src/Text/Mustache/Internal/Types.hs b/src/Text/Mustache/Internal/Types.hs --- a/src/Text/Mustache/Internal/Types.hs +++ b/src/Text/Mustache/Internal/Types.hs @@ -1,401 +1,468 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -module Text.Mustache.Internal.Types where - - -import Control.Arrow -import Control.Monad.RWS hiding (lift) -import qualified Data.Aeson as Aeson -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Map as Map -import Data.Scientific -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import Data.Text -import qualified Data.Text.Lazy as LT -import qualified Data.Vector as V -import Data.Word (Word8, Word16, Word32, Word64) -import Language.Haskell.TH.Lift (deriveLift) -import Language.Haskell.TH.Syntax -import Numeric.Natural (Natural) - - --- | Type of errors we may encounter during substitution. -data SubstitutionError - = VariableNotFound [Key] -- ^ The template contained a variable for which there was no data counterpart in the current context - | InvalidImplicitSectionContextType String -- ^ When substituting an implicit section the current context had an unsubstitutable type - | InvertedImplicitSection -- ^ Inverted implicit sections should never occur - | SectionTargetNotFound [Key] -- ^ The template contained a section for which there was no data counterpart in the current context - | PartialNotFound FilePath -- ^ The template contained a partial for which there was no data counterpart in the current context - | DirectlyRenderedValue Value -- ^ A complex value such as an Object or Array was directly rendered into the template (warning) - deriving (Show) - - -tellError :: SubstitutionError -> SubM () -tellError e = SubM $ tell ([e], []) - - -tellSuccess :: Text -> SubM () -tellSuccess s = SubM $ tell ([], [s]) - - -newtype SubM a = SubM { runSubM' :: RWS (Context Value, TemplateCache) ([SubstitutionError], [Text]) () a } deriving (Monad, Functor, Applicative, MonadReader (Context Value, TemplateCache)) - -runSubM :: SubM a -> Context Value -> TemplateCache -> ([SubstitutionError], [Text]) -runSubM comp ctx cache = snd $ evalRWS (runSubM' comp) (ctx, cache) () - -shiftContext :: Context Value -> SubM a -> SubM a -shiftContext = local . first . const - --- | Search for a key in the current context. --- --- The search is conducted inside out mening the current focus --- is searched first. If the key is not found the outer scopes are recursively --- searched until the key is found, then 'innerSearch' is called on the result. -search :: [Key] -> SubM (Maybe Value) -search [] = return Nothing -search (key:nextKeys) = (>>= innerSearch nextKeys) <$> go - where - go = asks fst >>= \case - Context parents focus -> do - let searchParents = case parents of - (newFocus: newParents) -> shiftContext (Context newParents newFocus) $ go - _ -> return Nothing - case focus of - Object o -> - case HM.lookup key o of - Just res -> return $ Just res - _ -> searchParents - _ -> searchParents - - --- | Searches nested scopes navigating inward. Fails if it encunters something --- other than an object before the key is expended. -innerSearch :: [Key] -> Value -> Maybe Value -innerSearch [] v = Just v -innerSearch (y:ys) (Object o) = HM.lookup y o >>= innerSearch ys -innerSearch _ _ = Nothing - - - --- | Syntax tree for a mustache template -type STree = ASTree Text - - -type ASTree α = [Node α] - - --- | Basic values composing the STree -data Node α - = TextBlock α - | Section DataIdentifier (ASTree α) - | InvertedSection DataIdentifier (ASTree α) - | Variable Bool DataIdentifier - | Partial (Maybe α) FilePath - deriving (Show, Eq) - - --- | Kinds of identifiers for Variables and sections -data DataIdentifier - = NamedData [Key] - | Implicit - deriving (Show, Eq) - - --- | A list-like structure used in 'Value' -type Array = V.Vector Value --- | A map-like structure used in 'Value' -type Object = HM.HashMap Text Value --- | Source type for constructing 'Object's -type Pair = (Text, Value) - - --- | Representation of stateful context for the substitution process -data Context α = Context { ctxtParents :: [α], ctxtFocus :: α } - deriving (Eq, Show, Ord) - --- | Internal value representation -data Value - = Object !Object - | Array !Array - | Number !Scientific - | String !Text - | Lambda (STree -> SubM STree) - | Bool !Bool - | Null - - -instance Show Value where - show (Lambda _) = "Lambda function" - show (Object o) = show o - show (Array a) = show a - show (String s) = show s - show (Number n) = show n - show (Bool b) = show b - show Null = "null" - - -listToMustache' :: ToMustache ω => [ω] -> Value -listToMustache' = Array . V.fromList . fmap toMustache - -integralToMustache :: Integral ω => ω -> Value -integralToMustache = toMustache . toInteger - --- | Conversion class -class ToMustache ω where - toMustache :: ω -> Value - listToMustache :: [ω] -> Value - listToMustache = listToMustache' - -instance ToMustache Float where - toMustache = Number . fromFloatDigits - -instance ToMustache Double where - toMustache = Number . fromFloatDigits - -instance ToMustache Integer where - toMustache = Number . fromInteger - -instance ToMustache Natural where - toMustache = integralToMustache - -instance ToMustache Int where - toMustache = integralToMustache - -instance ToMustache Word where - toMustache = integralToMustache - -instance ToMustache Int8 where - toMustache = integralToMustache - -instance ToMustache Int16 where - toMustache = integralToMustache - -instance ToMustache Int32 where - toMustache = integralToMustache - -instance ToMustache Int64 where - toMustache = integralToMustache - -instance ToMustache Word8 where - toMustache = integralToMustache - -instance ToMustache Word16 where - toMustache = integralToMustache - -instance ToMustache Word32 where - toMustache = integralToMustache - -instance ToMustache Word64 where - toMustache = integralToMustache - -instance ToMustache Char where - toMustache = toMustache . (:[]) - listToMustache = String . pack - -instance ToMustache Value where - toMustache = id - -instance ToMustache Bool where - toMustache = Bool - -instance ToMustache () where - toMustache = const Null - -instance ToMustache ω => ToMustache (Maybe ω) where - toMustache (Just w) = toMustache w - toMustache Nothing = Null - -instance ToMustache Text where - toMustache = String - -instance ToMustache LT.Text where - toMustache = String . LT.toStrict - -instance ToMustache Scientific where - toMustache = Number - -instance ToMustache α => ToMustache [α] where - toMustache = listToMustache - -instance ToMustache ω => ToMustache (Seq.Seq ω) where - toMustache = listToMustache' . toList - -instance ToMustache ω => ToMustache (V.Vector ω) where - toMustache = Array . fmap toMustache - -instance (ToMustache ω) => ToMustache (Map.Map Text ω) where - toMustache = mapInstanceHelper id - -instance (ToMustache ω) => ToMustache (Map.Map LT.Text ω) where - toMustache = mapInstanceHelper LT.toStrict - -instance (ToMustache ω) => ToMustache (Map.Map String ω) where - toMustache = mapInstanceHelper pack - -mapInstanceHelper :: ToMustache v => (a -> Text) -> Map.Map a v -> Value -mapInstanceHelper conv = - toMustache - . Map.foldrWithKey - (\k -> HM.insert (conv k) . toMustache) - HM.empty - -instance ToMustache ω => ToMustache (HM.HashMap Text ω) where - toMustache = Object . fmap toMustache - -instance ToMustache ω => ToMustache (HM.HashMap LT.Text ω) where - toMustache = hashMapInstanceHelper LT.toStrict - -instance ToMustache ω => ToMustache (HM.HashMap String ω) where - toMustache = hashMapInstanceHelper pack - -hashMapInstanceHelper :: ToMustache v => (a -> Text) -> HM.HashMap a v -> Value -hashMapInstanceHelper conv = - toMustache - . HM.foldrWithKey - (\k -> HM.insert (conv k) . toMustache) - HM.empty - -instance ToMustache (STree -> SubM STree) where - toMustache = Lambda - -instance ToMustache Aeson.Value where - toMustache (Aeson.Object o) = Object $ fmap toMustache o - toMustache (Aeson.Array a) = Array $ fmap toMustache a - toMustache (Aeson.Number n) = Number n - toMustache (Aeson.String s) = String s - toMustache (Aeson.Bool b) = Bool b - toMustache Aeson.Null = Null - -instance ToMustache ω => ToMustache (HS.HashSet ω) where - toMustache = listToMustache' . HS.toList - -instance ToMustache ω => ToMustache (Set.Set ω) where - toMustache = listToMustache' . Set.toList - -instance (ToMustache α, ToMustache β) => ToMustache (α, β) where - toMustache (a, b) = toMustache [toMustache a, toMustache b] - -instance (ToMustache α, ToMustache β, ToMustache γ) - => ToMustache (α, β, γ) where - toMustache (a, b, c) = toMustache [toMustache a, toMustache b, toMustache c] - -instance (ToMustache α, ToMustache β, ToMustache γ, ToMustache δ) - => ToMustache (α, β, γ, δ) where - toMustache (a, b, c, d) = toMustache - [ toMustache a - , toMustache b - , toMustache c - , toMustache d - ] - -instance ( ToMustache α - , ToMustache β - , ToMustache γ - , ToMustache δ - , ToMustache ε - ) => ToMustache (α, β, γ, δ, ε) where - toMustache (a, b, c, d, e) = toMustache - [ toMustache a - , toMustache b - , toMustache c - , toMustache d - , toMustache e - ] - -instance ( ToMustache α - , ToMustache β - , ToMustache γ - , ToMustache δ - , ToMustache ε - , ToMustache ζ - ) => ToMustache (α, β, γ, δ, ε, ζ) where - toMustache (a, b, c, d, e, f) = toMustache - [ toMustache a - , toMustache b - , toMustache c - , toMustache d - , toMustache e - , toMustache f - ] - -instance ( ToMustache α - , ToMustache β - , ToMustache γ - , ToMustache δ - , ToMustache ε - , ToMustache ζ - , ToMustache η - ) => ToMustache (α, β, γ, δ, ε, ζ, η) where - toMustache (a, b, c, d, e, f, g) = toMustache - [ toMustache a - , toMustache b - , toMustache c - , toMustache d - , toMustache e - , toMustache f - , toMustache g - ] - -instance ( ToMustache α - , ToMustache β - , ToMustache γ - , ToMustache δ - , ToMustache ε - , ToMustache ζ - , ToMustache η - , ToMustache θ - ) => ToMustache (α, β, γ, δ, ε, ζ, η, θ) where - toMustache (a, b, c, d, e, f, g, h) = toMustache - [ toMustache a - , toMustache b - , toMustache c - , toMustache d - , toMustache e - , toMustache f - , toMustache g - , toMustache h - ] - --- | A collection of templates with quick access via their hashed names -type TemplateCache = HM.HashMap String Template - --- | Type of key used for retrieving data from 'Value's -type Key = Text - -{-| - A compiled Template with metadata. --} -data Template = Template - { name :: String - , ast :: STree - , partials :: TemplateCache - } deriving (Show) - - -deriveLift ''DataIdentifier -deriveLift ''Node -deriveLift ''Template - -instance Lift TemplateCache where -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped m = [|| HM.fromList $$(liftTyped $ HM.toList m) ||] -#else - lift m = [| HM.fromList $(lift $ HM.toList m) |] -#endif - ---Data.Text 1.2.4.0 introduces its own Lift Text instance -#if !MIN_VERSION_text(1,2,4) -instance Lift Text where - lift = lift . unpack -#endif - +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +module Text.Mustache.Internal.Types + ( Array + , ASTree + , Context (..) + , DataIdentifier (..) + , Key + , Node (..) + , Object + , Pair + , STree + , SubM (..) + , SubstitutionError (..) + , Template (..) + , TemplateCache + , ToMustache (..) + , Value (..) + , innerSearch + , integralToMustache + , runSubM + , search + , shiftContext + , tellError + , tellSuccess + ) where + + +import Control.Arrow ( Arrow (..) ) +import Control.Monad.RWS + ( MonadReader (..), MonadWriter (..), RWS, RWST (..), asks + , evalRWS + ) +import qualified Data.Aeson as Aeson +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM +#endif +import Data.Foldable ( toList ) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Int ( Int8, Int16, Int32, Int64 ) +import qualified Data.Map as Map +import Data.Scientific ( Scientific, fromFloatDigits ) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Vector as V +import Data.Word ( Word8, Word16, Word32, Word64 ) +import Language.Haskell.TH.Lift (deriveLift) +#if !MIN_VERSION_unordered_containers(0,2,17) || !MIN_VERSION_text(1,2,4) +import Language.Haskell.TH.Syntax ( Lift (..) ) +#endif +import Numeric.Natural ( Natural ) + + +-- | Type of errors we may encounter during substitution. +data SubstitutionError + = VariableNotFound [Key] + -- ^ The template contained a variable for which there was no data + -- counterpart in the current context + | InvalidImplicitSectionContextType String + -- ^ When substituting an implicit section the current context had an + -- unsubstitutable type + | InvertedImplicitSection + -- ^ Inverted implicit sections should never occur + | SectionTargetNotFound [Key] + -- ^ The template contained a section for which there was no data + -- counterpart in the current context + | PartialNotFound FilePath + -- ^ The template contained a partial for which there was no data + -- counterpart in the current context + | DirectlyRenderedValue Value + -- ^ A complex value such as an Object or Array was directly rendered into + -- the template (warning) + deriving (Show) + + +tellError :: SubstitutionError -> SubM () +tellError e = SubM $ tell ([e], []) + + +tellSuccess :: Text -> SubM () +tellSuccess s = SubM $ tell ([], [s]) + + +newtype SubM a = SubM + { runSubM' :: RWS (Context Value, TemplateCache) ([SubstitutionError], [Text]) () a + } + deriving (Monad, Functor, Applicative, MonadReader (Context Value, TemplateCache)) + + +runSubM :: SubM a -> Context Value -> TemplateCache -> ([SubstitutionError], [Text]) +runSubM comp ctx cache = snd $ evalRWS (runSubM' comp) (ctx, cache) () + + +shiftContext :: Context Value -> SubM a -> SubM a +shiftContext = local . first . const + + +-- | Search for a key in the current context. +-- +-- The search is conducted inside out mening the current focus +-- is searched first. If the key is not found the outer scopes are recursively +-- searched until the key is found, then 'innerSearch' is called on the result. +search :: [Key] -> SubM (Maybe Value) +search [] = pure Nothing +search (key:nextKeys) = (>>= innerSearch nextKeys) <$> go + where + go = asks fst >>= \case + Context parents focus -> do + let searchParents = case parents of + (newFocus: newParents) -> shiftContext (Context newParents newFocus) go + _ -> pure Nothing + case focus of + Object o -> + case HM.lookup key o of + Just res -> pure $ Just res + _ -> searchParents + _ -> searchParents + + +-- | Searches nested scopes navigating inward. Fails if it encunters something +-- other than an object before the key is expended. +innerSearch :: [Key] -> Value -> Maybe Value +innerSearch [] v = Just v +innerSearch (y:ys) (Object o) = HM.lookup y o >>= innerSearch ys +innerSearch _ _ = Nothing + + +-- | Syntax tree for a mustache template +type STree = ASTree Text + + +type ASTree α = [Node α] + + +-- | Basic values composing the STree +data Node α + = TextBlock α + | Section DataIdentifier (ASTree α) + | InvertedSection DataIdentifier (ASTree α) + | Variable Bool DataIdentifier + | Partial (Maybe α) FilePath + deriving (Show, Eq) + + +-- | Kinds of identifiers for Variables and sections +data DataIdentifier + = NamedData [Key] + | Implicit + deriving (Show, Eq) + + +-- | A list-like structure used in 'Value' +type Array = V.Vector Value +-- | A map-like structure used in 'Value' +type Object = HM.HashMap Text Value +-- | Source type for constructing 'Object's +type Pair = (Text, Value) + + +-- | Representation of stateful context for the substitution process +data Context α = Context { ctxtParents :: [α], ctxtFocus :: α } + deriving (Eq, Show, Ord) + + +-- | Internal value representation +data Value + = Object !Object + | Array !Array + | Number !Scientific + | String !Text + | Lambda (STree -> SubM STree) + | Bool !Bool + | Null + + +instance Show Value where + show (Lambda _) = "Lambda function" + show (Object o) = show o + show (Array a) = show a + show (String s) = show s + show (Number n) = show n + show (Bool b) = show b + show Null = "null" + + +listToMustache' :: ToMustache ω => [ω] -> Value +listToMustache' = Array . V.fromList . fmap toMustache + + +integralToMustache :: Integral ω => ω -> Value +integralToMustache = toMustache . toInteger + + +-- | Conversion class +class ToMustache ω where + toMustache :: ω -> Value + listToMustache :: [ω] -> Value + listToMustache = listToMustache' + +instance ToMustache Float where + toMustache = Number . fromFloatDigits + +instance ToMustache Double where + toMustache = Number . fromFloatDigits + +instance ToMustache Integer where + toMustache = Number . fromInteger + +instance ToMustache Natural where + toMustache = integralToMustache + +instance ToMustache Int where + toMustache = integralToMustache + +instance ToMustache Word where + toMustache = integralToMustache + +instance ToMustache Int8 where + toMustache = integralToMustache + +instance ToMustache Int16 where + toMustache = integralToMustache + +instance ToMustache Int32 where + toMustache = integralToMustache + +instance ToMustache Int64 where + toMustache = integralToMustache + +instance ToMustache Word8 where + toMustache = integralToMustache + +instance ToMustache Word16 where + toMustache = integralToMustache + +instance ToMustache Word32 where + toMustache = integralToMustache + +instance ToMustache Word64 where + toMustache = integralToMustache + +instance ToMustache Char where + toMustache = toMustache . (:[]) + listToMustache = String . T.pack + +instance ToMustache Value where + toMustache = id + +instance ToMustache Bool where + toMustache = Bool + +instance ToMustache () where + toMustache = const Null + +instance ToMustache ω => ToMustache (Maybe ω) where + toMustache (Just w) = toMustache w + toMustache Nothing = Null + +instance ToMustache Text where + toMustache = String + +instance ToMustache LT.Text where + toMustache = String . LT.toStrict + +instance ToMustache Scientific where + toMustache = Number + +instance ToMustache α => ToMustache [α] where + toMustache = listToMustache + +instance ToMustache ω => ToMustache (Seq.Seq ω) where + toMustache = listToMustache' . toList + +instance ToMustache ω => ToMustache (V.Vector ω) where + toMustache = Array . fmap toMustache + +instance (ToMustache ω) => ToMustache (Map.Map Text ω) where + toMustache = mapInstanceHelper id + +instance (ToMustache ω) => ToMustache (Map.Map LT.Text ω) where + toMustache = mapInstanceHelper LT.toStrict + +instance (ToMustache ω) => ToMustache (Map.Map String ω) where + toMustache = mapInstanceHelper T.pack + + +mapInstanceHelper :: ToMustache v => (a -> Text) -> Map.Map a v -> Value +mapInstanceHelper conv = + toMustache + . Map.foldrWithKey + (\k -> HM.insert (conv k) . toMustache) + HM.empty + + +instance ToMustache ω => ToMustache (HM.HashMap Text ω) where + toMustache = Object . fmap toMustache + +instance ToMustache ω => ToMustache (HM.HashMap LT.Text ω) where + toMustache = hashMapInstanceHelper LT.toStrict + +instance ToMustache ω => ToMustache (HM.HashMap String ω) where + toMustache = hashMapInstanceHelper T.pack + + +hashMapInstanceHelper :: ToMustache v => (a -> Text) -> HM.HashMap a v -> Value +hashMapInstanceHelper conv = + toMustache + . HM.foldrWithKey + (\k -> HM.insert (conv k) . toMustache) + HM.empty + + +instance ToMustache (STree -> SubM STree) where + toMustache = Lambda + +instance ToMustache Aeson.Value where + toMustache (Aeson.Object o) = Object $ fmap toMustache +#if MIN_VERSION_aeson(2,0,0) + (KM.toHashMapText o) +#else + o +#endif + toMustache (Aeson.Array a) = Array $ fmap toMustache a + toMustache (Aeson.Number n) = Number n + toMustache (Aeson.String s) = String s + toMustache (Aeson.Bool b) = Bool b + toMustache Aeson.Null = Null + +instance ToMustache ω => ToMustache (HS.HashSet ω) where + toMustache = listToMustache' . HS.toList + +instance ToMustache ω => ToMustache (Set.Set ω) where + toMustache = listToMustache' . Set.toList + +instance (ToMustache α, ToMustache β) => ToMustache (α, β) where + toMustache (a, b) = toMustache [toMustache a, toMustache b] + +instance (ToMustache α, ToMustache β, ToMustache γ) + => ToMustache (α, β, γ) where + toMustache (a, b, c) = toMustache [toMustache a, toMustache b, toMustache c] + +instance (ToMustache α, ToMustache β, ToMustache γ, ToMustache δ) + => ToMustache (α, β, γ, δ) where + toMustache (a, b, c, d) = toMustache + [ toMustache a + , toMustache b + , toMustache c + , toMustache d + ] + +instance ( ToMustache α + , ToMustache β + , ToMustache γ + , ToMustache δ + , ToMustache ε + ) => ToMustache (α, β, γ, δ, ε) where + toMustache (a, b, c, d, e) = toMustache + [ toMustache a + , toMustache b + , toMustache c + , toMustache d + , toMustache e + ] + +instance ( ToMustache α + , ToMustache β + , ToMustache γ + , ToMustache δ + , ToMustache ε + , ToMustache ζ + ) => ToMustache (α, β, γ, δ, ε, ζ) where + toMustache (a, b, c, d, e, f) = toMustache + [ toMustache a + , toMustache b + , toMustache c + , toMustache d + , toMustache e + , toMustache f + ] + +instance ( ToMustache α + , ToMustache β + , ToMustache γ + , ToMustache δ + , ToMustache ε + , ToMustache ζ + , ToMustache η + ) => ToMustache (α, β, γ, δ, ε, ζ, η) where + toMustache (a, b, c, d, e, f, g) = toMustache + [ toMustache a + , toMustache b + , toMustache c + , toMustache d + , toMustache e + , toMustache f + , toMustache g + ] + +instance ( ToMustache α + , ToMustache β + , ToMustache γ + , ToMustache δ + , ToMustache ε + , ToMustache ζ + , ToMustache η + , ToMustache θ + ) => ToMustache (α, β, γ, δ, ε, ζ, η, θ) where + toMustache (a, b, c, d, e, f, g, h) = toMustache + [ toMustache a + , toMustache b + , toMustache c + , toMustache d + , toMustache e + , toMustache f + , toMustache g + , toMustache h + ] + + +-- | A collection of templates with quick access via their hashed names +type TemplateCache = HM.HashMap String Template + + +-- | Type of key used for retrieving data from 'Value's +type Key = Text + + +{-| + A compiled Template with metadata. +-} +data Template = Template + { name :: String + , ast :: STree + , partials :: TemplateCache + } deriving (Show) + + +deriveLift ''DataIdentifier +deriveLift ''Node +deriveLift ''Template + + +-- Data.HashMap 0.2.17.0 introduces its own Lift instance +#if !MIN_VERSION_unordered_containers(0,2,17) +instance Lift TemplateCache where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped m = [|| HM.fromList $$(liftTyped $ HM.toList m) ||] +#else + lift m = [| HM.fromList $(lift $ HM.toList m) |] +#endif +#endif + + +--Data.Text 1.2.4.0 introduces its own Lift Text instance +#if !MIN_VERSION_text(1,2,4) +instance Lift Text where + lift = lift . T.unpack +#endif diff --git a/src/Text/Mustache/Parser.hs b/src/Text/Mustache/Parser.hs --- a/src/Text/Mustache/Parser.hs +++ b/src/Text/Mustache/Parser.hs @@ -1,311 +1,349 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -module Text.Mustache.Parser - ( - -- * Generic parsing functions - - parse, parseWithConf - - -- * Configurations - - , MustacheConf(..), defaultConf - - -- * Parser - - , Parser, MustacheState - - -- * Mustache Constants - - , sectionBegin, sectionEnd, invertedSectionBegin, unescape2, unescape1 - , delimiterChange, nestingSeparator - - ) where - - -import Control.Monad -import Data.Char (isAlphaNum, isSpace) -import Data.List (nub) -import Data.Monoid ((<>)) -import Data.Text as T (Text, null, pack) -import Prelude as Prel -import Text.Mustache.Types -import Text.Parsec as P hiding (endOfLine, parse) - - --- | Initial configuration for the parser -data MustacheConf = MustacheConf - { delimiters :: (String, String) - } - - --- | User state for the parser -data MustacheState = MustacheState - { sDelimiters :: (String, String) - , textStack :: Text - , isBeginngingOfLine :: Bool - , currentSectionName :: Maybe DataIdentifier - } - - -data ParseTagRes - = SectionBegin Bool DataIdentifier - | SectionEnd DataIdentifier - | Tag (Node Text) - | HandledTag - - --- | @#@ -sectionBegin :: Char -sectionBegin = '#' --- | @/@ -sectionEnd :: Char -sectionEnd = '/' --- | @>@ -partialBegin :: Char -partialBegin = '>' --- | @^@ -invertedSectionBegin :: Char -invertedSectionBegin = '^' --- | @{@ and @}@ -unescape2 :: (Char, Char) -unescape2 = ('{', '}') --- | @&@ -unescape1 :: Char -unescape1 = '&' --- | @=@ -delimiterChange :: Char -delimiterChange = '=' --- | @.@ -nestingSeparator :: Char -nestingSeparator = '.' --- | @!@ -comment :: Char -comment = '!' --- | @.@ -implicitIterator :: Char -implicitIterator = '.' --- | Cannot be a letter, number or the nesting separation Character @.@ -isAllowedDelimiterCharacter :: Char -> Bool -isAllowedDelimiterCharacter = - not . Prel.or . sequence - [ isSpace, isAlphaNum, (== nestingSeparator) ] -allowedDelimiterCharacter :: Parser Char -allowedDelimiterCharacter = - satisfy isAllowedDelimiterCharacter - - --- | Empty configuration -emptyState :: MustacheState -emptyState = MustacheState ("", "") mempty True Nothing - - --- | Default configuration (delimiters = ("{{", "}}")) -defaultConf :: MustacheConf -defaultConf = MustacheConf ("{{", "}}") - - -initState :: MustacheConf -> MustacheState -initState (MustacheConf { delimiters }) = emptyState { sDelimiters = delimiters } - - -setIsBeginning :: Bool -> Parser () -setIsBeginning b = modifyState (\s -> s { isBeginngingOfLine = b }) - - --- | The parser monad in use -type Parser = Parsec Text MustacheState - - -(<<) :: Monad m => m b -> m a -> m b -(<<) = flip (>>) - - -endOfLine :: Parser String -endOfLine = do - r <- optionMaybe $ char '\r' - n <- char '\n' - return $ maybe id (:) r [n] - - -{-| - Runs the parser for a mustache template, returning the syntax tree. --} -parse :: FilePath -> Text -> Either ParseError STree -parse = parseWithConf defaultConf - - --- | Parse using a custom initial configuration -parseWithConf :: MustacheConf -> FilePath -> Text -> Either ParseError STree -parseWithConf = P.runParser parseText . initState - - -parseText :: Parser STree -parseText = do - (MustacheState { isBeginngingOfLine }) <- getState - if isBeginngingOfLine - then parseLine - else continueLine - - -appendStringStack :: String -> Parser () -appendStringStack t = modifyState (\s -> s { textStack = textStack s <> pack t}) - - -continueLine :: Parser STree -continueLine = do - (MustacheState { sDelimiters = ( start@(x:_), _ )}) <- getState - let forbidden = x : "\n\r" - - many (noneOf forbidden) >>= appendStringStack - - (try endOfLine >>= appendStringStack >> setIsBeginning True >> parseLine) - <|> (try (string start) >> switchOnTag >>= continueFromTag) - <|> (try eof >> finishFile) - <|> (anyChar >>= appendStringStack . (:[]) >> continueLine) - - -flushText :: Parser STree -flushText = do - s@(MustacheState { textStack = text }) <- getState - putState $ s { textStack = mempty } - return $ if T.null text - then [] - else [TextBlock text] - - -finishFile :: Parser STree -finishFile = - getState >>= \case - (MustacheState {currentSectionName = Nothing}) -> flushText - (MustacheState {currentSectionName = Just name}) -> - parserFail $ "Unclosed section " <> show name - - -parseLine :: Parser STree -parseLine = do - (MustacheState { sDelimiters = ( start, _ ) }) <- getState - initialWhitespace <- many (oneOf " \t") - let handleStandalone = do - tag <- switchOnTag - let continueNoStandalone = do - appendStringStack initialWhitespace - setIsBeginning False - continueFromTag tag - standaloneEnding = do - try (skipMany (oneOf " \t") >> (eof <|> void endOfLine)) - setIsBeginning True - case tag of - Tag (Partial _ name) -> - ( standaloneEnding >> - continueFromTag (Tag (Partial (Just (pack initialWhitespace)) name)) - ) <|> continueNoStandalone - Tag _ -> continueNoStandalone - _ -> - ( standaloneEnding >> - continueFromTag tag - ) <|> continueNoStandalone - (try (string start) >> handleStandalone) - <|> (try eof >> appendStringStack initialWhitespace >> finishFile) - <|> (appendStringStack initialWhitespace >> setIsBeginning False >> continueLine) - - -continueFromTag :: ParseTagRes -> Parser STree -continueFromTag (SectionBegin inverted name) = do - textNodes <- flushText - state@(MustacheState - { currentSectionName = previousSection }) <- getState - putState $ state { currentSectionName = return name } - innerSectionContent <- parseText - let sectionTag = - if inverted - then InvertedSection - else Section - modifyState $ \s -> s { currentSectionName = previousSection } - outerSectionContent <- parseText - return (textNodes <> [sectionTag name innerSectionContent] <> outerSectionContent) -continueFromTag (SectionEnd name) = do - (MustacheState - { currentSectionName }) <- getState - case currentSectionName of - Just name' | name' == name -> flushText - Just name' -> parserFail $ "Expected closing sequence for \"" <> show name <> "\" got \"" <> show name' <> "\"." - Nothing -> parserFail $ "Encountered closing sequence for \"" <> show name <> "\" which has never been opened." -continueFromTag (Tag tag) = do - textNodes <- flushText - furtherNodes <- parseText - return $ textNodes <> return tag <> furtherNodes -continueFromTag HandledTag = parseText - - -switchOnTag :: Parser ParseTagRes -switchOnTag = do - (MustacheState { sDelimiters = ( _, end )}) <- getState - - choice - [ SectionBegin False <$> (try (char sectionBegin) >> genParseTagEnd mempty) - , SectionEnd - <$> (try (char sectionEnd) >> genParseTagEnd mempty) - , Tag . Variable False - <$> (try (char unescape1) >> genParseTagEnd mempty) - , Tag . Variable False - <$> (try (char (fst unescape2)) >> genParseTagEnd (return $ snd unescape2)) - , Tag . Partial Nothing - <$> (try (char partialBegin) >> spaces >> (noneOf (nub end) `manyTill` try (spaces >> string end))) - , return HandledTag - << (try (char delimiterChange) >> parseDelimChange) - , SectionBegin True - <$> (try (char invertedSectionBegin) >> genParseTagEnd mempty >>= \case - n@(NamedData _) -> return n - _ -> parserFail "Inverted Sections can not be implicit." - ) - , return HandledTag << (try (char comment) >> manyTill anyChar (try $ string end)) - , Tag . Variable True - <$> genParseTagEnd mempty - ] - where - parseDelimChange = do - (MustacheState { sDelimiters = ( _, end )}) <- getState - spaces - delim1 <- allowedDelimiterCharacter `manyTill` space - spaces - delim2 <- allowedDelimiterCharacter `manyTill` try (spaces >> string (delimiterChange : end)) - when (delim1 == mempty || delim2 == mempty) - $ parserFail "Tags must contain more than 0 characters" - oldState <- getState - putState $ oldState { sDelimiters = (delim1, delim2) } - - -genParseTagEnd :: String -> Parser DataIdentifier -genParseTagEnd emod = do - (MustacheState { sDelimiters = ( start, end ) }) <- getState - - let nEnd = emod <> end - disallowed = nub $ nestingSeparator : start <> end - - parseOne :: Parser [Text] - parseOne = do - - one <- noneOf disallowed - `manyTill` lookAhead - (try (spaces >> void (string nEnd)) - <|> try (void $ char nestingSeparator)) - - others <- (char nestingSeparator >> parseOne) - <|> (const mempty <$> (spaces >> string nEnd)) - return $ pack one : others - spaces - (try (char implicitIterator) >> spaces >> string nEnd >> return Implicit) - <|> (NamedData <$> parseOne) +{-| +Module : $Header$ +Description : Basic functions for dealing with mustache templates. +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.Mustache.Parser + ( + -- * Generic parsing functions + parse + , parseWithConf + -- * Configurations + , MustacheConf (..) + , defaultConf + -- * Parser + , Parser + , MustacheState + -- * Mustache Constants + , sectionBegin + , sectionEnd + , invertedSectionBegin + , unescape2 + , unescape1 + , delimiterChange + , nestingSeparator + ) where + + +import Control.Monad ( void, when ) +import Data.Char ( isAlphaNum, isSpace ) +import Data.List ( nub ) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif +import Data.Text ( Text ) +import qualified Data.Text as T +import Text.Mustache.Types ( DataIdentifier (..), Node (..), STree ) +import Text.Parsec + ( Parsec, ParseError, (<|>), anyChar, char, choice, eof + , getState, lookAhead, many, manyTill, modifyState, noneOf + , optionMaybe, oneOf, parserFail, putState, runParser + , satisfy, skipMany, space, spaces, string, try + ) + + +-- | Initial configuration for the parser +newtype MustacheConf = MustacheConf + { delimiters :: (String, String) + } + + +-- | User state for the parser +data MustacheState = MustacheState + { sDelimiters :: (String, String) + , textStack :: Text + , isBeginngingOfLine :: Bool + , currentSectionName :: Maybe DataIdentifier + } + + +data ParseTagRes + = SectionBegin Bool DataIdentifier + | SectionEnd DataIdentifier + | Tag (Node Text) + | HandledTag + + +-- | @#@ +sectionBegin :: Char +sectionBegin = '#' + + +-- | @/@ +sectionEnd :: Char +sectionEnd = '/' + + +-- | @>@ +partialBegin :: Char +partialBegin = '>' + + +-- | @^@ +invertedSectionBegin :: Char +invertedSectionBegin = '^' + + +-- | @{@ and @}@ +unescape2 :: (Char, Char) +unescape2 = ('{', '}') + + +-- | @&@ +unescape1 :: Char +unescape1 = '&' + + +-- | @=@ +delimiterChange :: Char +delimiterChange = '=' + + +-- | @.@ +nestingSeparator :: Char +nestingSeparator = '.' + + +-- | @!@ +comment :: Char +comment = '!' + + +-- | @.@ +implicitIterator :: Char +implicitIterator = '.' + + +-- | Cannot be a letter, number or the nesting separation Character @.@ +isAllowedDelimiterCharacter :: Char -> Bool +isAllowedDelimiterCharacter = + not . or . sequence + [ isSpace, isAlphaNum, (== nestingSeparator) ] + + +allowedDelimiterCharacter :: Parser Char +allowedDelimiterCharacter = + satisfy isAllowedDelimiterCharacter + + +-- | Empty configuration +emptyState :: MustacheState +emptyState = MustacheState ("", "") mempty True Nothing + + +-- | Default configuration (delimiters = ("{{", "}}")) +defaultConf :: MustacheConf +defaultConf = MustacheConf ("{{", "}}") + + +initState :: MustacheConf -> MustacheState +initState (MustacheConf { delimiters }) = emptyState { sDelimiters = delimiters } + + +setIsBeginning :: Bool -> Parser () +setIsBeginning b = modifyState (\s -> s { isBeginngingOfLine = b }) + + +-- | The parser monad in use +type Parser = Parsec Text MustacheState + + +(<<) :: Monad m => m b -> m a -> m b +(<<) = flip (>>) + + +endOfLine :: Parser String +endOfLine = do + r <- optionMaybe $ char '\r' + n <- char '\n' + pure $ maybe id (:) r [n] + + +{-| + Runs the parser for a mustache template, returning the syntax tree. +-} +parse :: FilePath -> Text -> Either ParseError STree +parse = parseWithConf defaultConf + + +-- | Parse using a custom initial configuration +parseWithConf :: MustacheConf -> FilePath -> Text -> Either ParseError STree +parseWithConf = runParser parseText . initState + + +parseText :: Parser STree +parseText = do + (MustacheState { isBeginngingOfLine }) <- getState + if isBeginngingOfLine + then parseLine + else continueLine + + +appendStringStack :: String -> Parser () +appendStringStack t = modifyState (\s -> s { textStack = textStack s <> T.pack t}) + + +continueLine :: Parser STree +continueLine = do + (MustacheState { sDelimiters = ( start@(x:_), _ )}) <- getState + let forbidden = x : "\n\r" + + many (noneOf forbidden) >>= appendStringStack + + (try endOfLine >>= appendStringStack >> setIsBeginning True >> parseLine) + <|> (try (string start) >> switchOnTag >>= continueFromTag) + <|> (try eof >> finishFile) + <|> (anyChar >>= appendStringStack . (:[]) >> continueLine) + + +flushText :: Parser STree +flushText = do + s@(MustacheState { textStack = text }) <- getState + putState $ s { textStack = mempty } + pure [TextBlock text | not (T.null text)] + + +finishFile :: Parser STree +finishFile = + getState >>= \case + (MustacheState {currentSectionName = Nothing}) -> flushText + (MustacheState {currentSectionName = Just name}) -> + parserFail $ "Unclosed section " <> show name + + +parseLine :: Parser STree +parseLine = do + (MustacheState { sDelimiters = ( start, _ ) }) <- getState + initialWhitespace <- many (oneOf " \t") + let handleStandalone = do + tag <- switchOnTag + let continueNoStandalone = do + appendStringStack initialWhitespace + setIsBeginning False + continueFromTag tag + standaloneEnding = do + try (skipMany (oneOf " \t") >> (eof <|> void endOfLine)) + setIsBeginning True + case tag of + Tag (Partial _ name) -> + ( standaloneEnding >> + continueFromTag (Tag (Partial (Just (T.pack initialWhitespace)) name)) + ) <|> continueNoStandalone + Tag _ -> continueNoStandalone + _ -> + ( standaloneEnding >> + continueFromTag tag + ) <|> continueNoStandalone + (try (string start) >> handleStandalone) + <|> (try eof >> appendStringStack initialWhitespace >> finishFile) + <|> (appendStringStack initialWhitespace >> setIsBeginning False >> continueLine) + + +continueFromTag :: ParseTagRes -> Parser STree +continueFromTag (SectionBegin inverted name) = do + textNodes <- flushText + state@(MustacheState + { currentSectionName = previousSection }) <- getState + putState $ state { currentSectionName = pure name } + innerSectionContent <- parseText + let sectionTag = + if inverted + then InvertedSection + else Section + modifyState $ \s -> s { currentSectionName = previousSection } + outerSectionContent <- parseText + pure (textNodes <> [sectionTag name innerSectionContent] <> outerSectionContent) +continueFromTag (SectionEnd name) = do + (MustacheState + { currentSectionName }) <- getState + case currentSectionName of + Just name' | name' == name -> flushText + Just name' -> parserFail $ + "Expected closing sequence for \"" + <> show name + <> "\" got \"" + <> show name' + <> "\"." + Nothing -> parserFail $ + "Encountered closing sequence for \"" + <> show name + <> "\" which has never been opened." +continueFromTag (Tag tag) = do + textNodes <- flushText + furtherNodes <- parseText + pure $ textNodes <> pure tag <> furtherNodes +continueFromTag HandledTag = parseText + + +switchOnTag :: Parser ParseTagRes +switchOnTag = do + (MustacheState { sDelimiters = ( _, end )}) <- getState + + choice + [ SectionBegin False <$> (try (char sectionBegin) >> genParseTagEnd mempty) + , SectionEnd + <$> (try (char sectionEnd) >> genParseTagEnd mempty) + , Tag . Variable False + <$> (try (char unescape1) >> genParseTagEnd mempty) + , Tag . Variable False + <$> (try (char (fst unescape2)) >> genParseTagEnd (pure $ snd unescape2)) + , Tag . Partial Nothing + <$> ( try (char partialBegin) + >> spaces + >> (noneOf (nub end) `manyTill` try (spaces >> string end)) + ) + , pure HandledTag + << (try (char delimiterChange) >> parseDelimChange) + , SectionBegin True + <$> (try (char invertedSectionBegin) >> genParseTagEnd mempty >>= \case + n@(NamedData _) -> pure n + _ -> parserFail "Inverted Sections can not be implicit." + ) + , pure HandledTag << (try (char comment) >> manyTill anyChar (try $ string end)) + , Tag . Variable True + <$> genParseTagEnd mempty + ] + where + parseDelimChange = do + (MustacheState { sDelimiters = ( _, end )}) <- getState + spaces + delim1 <- allowedDelimiterCharacter `manyTill` space + spaces + delim2 <- allowedDelimiterCharacter `manyTill` try (spaces >> string (delimiterChange : end)) + when (delim1 == mempty || delim2 == mempty) + $ parserFail "Tags must contain more than 0 characters" + oldState <- getState + putState $ oldState { sDelimiters = (delim1, delim2) } + + +genParseTagEnd :: String -> Parser DataIdentifier +genParseTagEnd emod = do + (MustacheState { sDelimiters = ( start, end ) }) <- getState + + let nEnd = emod <> end + disallowed = nub $ nestingSeparator : start <> end + + parseOne :: Parser [Text] + parseOne = do + + one <- noneOf disallowed + `manyTill` lookAhead + (try (spaces >> void (string nEnd)) + <|> try (void $ char nestingSeparator)) + + others <- (char nestingSeparator >> parseOne) + <|> (mempty <$ (spaces >> string nEnd)) + pure $ T.pack one : others + spaces + (try (char implicitIterator) >> spaces >> string nEnd >> pure Implicit) + <|> (NamedData <$> parseOne) diff --git a/src/Text/Mustache/Render.hs b/src/Text/Mustache/Render.hs --- a/src/Text/Mustache/Render.hs +++ b/src/Text/Mustache/Render.hs @@ -1,247 +1,269 @@ -{-| -Module : $Header$ -Description : Functions for rendering mustache templates. -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Text.Mustache.Render - ( - -- * Substitution - substitute, substituteValue - -- * Checked substitution - , checkedSubstitute, checkedSubstituteValue, SubstitutionError(..) - -- * Working with Context - , Context(..), search, innerSearch, SubM, substituteNode, substituteAST, catchSubstitute - -- * Util - , toString - ) where - - -import Control.Arrow (first, second) -import Control.Monad - -import Data.Foldable (for_) -import Data.HashMap.Strict as HM hiding (keys, map) -import Data.Maybe (fromMaybe) - -import Data.Scientific (floatingOrInteger) -import Data.Text as T (Text, isSuffixOf, pack, - replace, stripSuffix) -import qualified Data.Vector as V -import Prelude hiding (length, lines, unlines) - -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Text.Mustache.Internal -import Text.Mustache.Internal.Types -import Text.Mustache.Types - - -{-| - Substitutes all mustache defined tokens (or tags) for values found in the - provided data structure. - - Equivalent to @substituteValue . toMustache@. --} -substitute :: ToMustache k => Template -> k -> Text -substitute t = substituteValue t . toMustache - - -{-| - Substitutes all mustache defined tokens (or tags) for values found in the - provided data structure and report any errors and warnings encountered during - substitution. - - This function always produces results, as in a fully substituted/rendered template, - it never halts on errors. It simply reports them in the first part of the tuple. - Sites with errors are usually substituted with empty string. - - The second value in the tuple is a template rendered with errors ignored. - Therefore if you must enforce that there were no errors during substitution - you must check that the error list in the first tuple value is empty. - - Equivalent to @checkedSubstituteValue . toMustache@. --} -checkedSubstitute :: ToMustache k => Template -> k -> ([SubstitutionError], Text) -checkedSubstitute t = checkedSubstituteValue t . toMustache - - -{-| - Substitutes all mustache defined tokens (or tags) for values found in the - provided data structure. --} -substituteValue :: Template -> Value -> Text -substituteValue = (snd .) . checkedSubstituteValue - - -{-| - Substitutes all mustache defined tokens (or tags) for values found in the - provided data structure and report any errors and warnings encountered during - substitution. - - This function always produces results, as in a fully substituted/rendered template, - it never halts on errors. It simply reports them in the first part of the tuple. - Sites with errors are usually substituted with empty string. - - The second value in the tuple is a template rendered with errors ignored. - Therefore if you must enforce that there were no errors during substitution - you must check that the error list in the first tuple value is empty. --} -checkedSubstituteValue :: Template -> Value -> ([SubstitutionError], Text) -checkedSubstituteValue template dataStruct = - second T.concat $ runSubM (substituteAST (ast template)) (Context mempty dataStruct) (partials template) - --- | Catch the results of running the inner substitution. -catchSubstitute :: SubM a -> SubM (a, Text) -catchSubstitute = fmap (second (T.concat . snd)) . SubM . hideResults . listen . runSubM' - where - hideResults = censor (\(errs, _) -> (errs, [])) - --- | Substitute an entire 'STree' rather than just a single 'Node' -substituteAST :: STree -> SubM () -substituteAST = mapM_ substituteNode - - --- | Main substitution function -substituteNode :: Node Text -> SubM () - --- subtituting text -substituteNode (TextBlock t) = tellSuccess t - --- substituting a whole section (entails a focus shift) -substituteNode (Section Implicit secSTree) = - asks fst >>= \case - Context parents focus@(Array a) - | V.null a -> return () - | otherwise -> for_ a $ \focus' -> - let newContext = Context (focus:parents) focus' - in shiftContext newContext $ substituteAST secSTree - Context _ (Object _) -> substituteAST secSTree - Context _ v -> tellError $ InvalidImplicitSectionContextType $ showValueType v - -substituteNode (Section (NamedData secName) secSTree) = - search secName >>= \case - Just arr@(Array arrCont) -> - if V.null arrCont - then return () - else do - Context parents focus <- asks fst - for_ arrCont $ \focus' -> - let newContext = Context (arr:focus:parents) focus' - in shiftContext newContext $ substituteAST secSTree - Just (Bool False) -> return () - Just Null -> return () - Just (Lambda l) -> substituteAST =<< l secSTree - Just focus' -> do - Context parents focus <- asks fst - let newContext = Context (focus:parents) focus' - shiftContext newContext $ substituteAST secSTree - Nothing -> tellError $ SectionTargetNotFound secName - --- substituting an inverted section -substituteNode (InvertedSection Implicit _) = tellError InvertedImplicitSection -substituteNode (InvertedSection (NamedData secName) invSecSTree) = - search secName >>= \case - Just (Bool False) -> contents - Just (Array a) | V.null a -> contents - Nothing -> contents - _ -> return () - where - contents = mapM_ substituteNode invSecSTree - --- substituting a variable -substituteNode (Variable _ Implicit) = asks (ctxtFocus . fst) >>= toString >>= tellSuccess -substituteNode (Variable escaped (NamedData varName)) = - maybe - (tellError $ VariableNotFound varName) - (toString >=> tellSuccess . (if escaped then escapeXMLText else id)) - =<< search varName - --- substituting a partial -substituteNode (Partial indent pName) = do - cPartials <- asks snd - case HM.lookup pName cPartials of - Nothing -> tellError $ PartialNotFound pName - Just t -> - let ast' = handleIndent indent $ ast t - in local (second (partials t `HM.union`)) $ substituteAST ast' - - -showValueType :: Value -> String -showValueType Null = "Null" -showValueType (Object _) = "Object" -showValueType (Array _) = "Array" -showValueType (String _) = "String" -showValueType (Lambda _) = "Lambda" -showValueType (Number _) = "Number" -showValueType (Bool _) = "Bool" - - -handleIndent :: Maybe Text -> STree -> STree -handleIndent Nothing ast' = ast' -handleIndent (Just indentation) ast' = preface <> content - where - preface = if T.null indentation then [] else [TextBlock indentation] - content = if T.null indentation - then ast' - else reverse $ fromMaybe [] (uncurry (:) . first dropper <$> uncons (reverse fullIndented)) - where - fullIndented = fmap (indentBy indentation) ast' - dropper (TextBlock t) = TextBlock $ - if ("\n" <> indentation) `isSuffixOf` t - then fromMaybe t $ stripSuffix indentation t - else t - dropper a = a - -indentBy :: Text -> Node Text -> Node Text -indentBy indent p@(Partial (Just indent') name') - | T.null indent = p - | otherwise = Partial (Just (indent <> indent')) name' -indentBy indent (Partial Nothing name') = Partial (Just indent) name' -indentBy indent (TextBlock t) = TextBlock $ replace "\n" ("\n" <> indent) t -indentBy _ a = a - - - --- | Converts values to Text as required by the mustache standard -toString :: Value -> SubM Text -toString (String t) = return t -toString (Number n) = return $ either (pack . show) (pack . show) (floatingOrInteger n :: Either Double Integer) -toString (Lambda l) = do - ((), res) <- catchSubstitute $ substituteAST =<< l [] - return res -toString e = do - tellError $ DirectlyRenderedValue e - return $ pack $ show e - - -instance ToMustache (Context Value -> STree -> STree) where - toMustache f = Lambda $ (<$> askContext) . flip f - -instance ToMustache (Context Value -> STree -> Text) where - toMustache = lambdaHelper id - -instance ToMustache (Context Value -> STree -> LT.Text) where - toMustache = lambdaHelper LT.toStrict - -instance ToMustache (Context Value -> STree -> String) where - toMustache = lambdaHelper pack - -lambdaHelper :: (r -> Text) -> (Context Value -> STree -> r) -> Value -lambdaHelper conv f = Lambda $ (<$> askContext) . wrapper - where - wrapper :: STree -> Context Value -> STree - wrapper lSTree c = [TextBlock $ conv $ f c lSTree] - -instance ToMustache (STree -> SubM Text) where - toMustache f = Lambda (fmap (return . TextBlock) . f) +{-| +Module : $Header$ +Description : Functions for rendering mustache templates. +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.Mustache.Render + ( + -- * Substitution + substitute + , substituteValue + -- * Checked substitution + , checkedSubstitute + , checkedSubstituteValue + , SubstitutionError (..) + -- * Working with Context + , Context (..) + , search + , innerSearch + , SubM + , substituteNode + , substituteAST + , catchSubstitute + -- * Util + , toString + ) where + + +import Control.Arrow ( first, second ) +import Control.Monad ( (>=>) ) +import Control.Monad.Reader ( MonadReader (..), asks ) +import Control.Monad.Writer ( MonadWriter (..), censor ) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif +import Data.Foldable ( for_ ) +import qualified Data.HashMap.Strict as HM +import Data.Maybe ( fromMaybe ) +import Data.Scientific ( floatingOrInteger ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Vector as V +import Text.Mustache.Internal ( escapeXMLText, uncons ) +import Text.Mustache.Internal.Types + ( SubM (..), SubstitutionError (..), innerSearch, runSubM + , search, shiftContext, tellError, tellSuccess + ) +import Text.Mustache.Types + ( Context (..), DataIdentifier (..), Node (..), STree + , Template (..), ToMustache (..), Value (..), askContext + ) + + +{-| + Substitutes all mustache defined tokens (or tags) for values found in the + provided data structure. + + Equivalent to @substituteValue . toMustache@. +-} +substitute :: ToMustache k => Template -> k -> Text +substitute t = substituteValue t . toMustache + + +{-| + Substitutes all mustache defined tokens (or tags) for values found in the + provided data structure and report any errors and warnings encountered during + substitution. + + This function always produces results, as in a fully substituted/rendered template, + it never halts on errors. It simply reports them in the first part of the tuple. + Sites with errors are usually substituted with empty string. + + The second value in the tuple is a template rendered with errors ignored. + Therefore if you must enforce that there were no errors during substitution + you must check that the error list in the first tuple value is empty. + + Equivalent to @checkedSubstituteValue . toMustache@. +-} +checkedSubstitute :: ToMustache k => Template -> k -> ([SubstitutionError], Text) +checkedSubstitute t = checkedSubstituteValue t . toMustache + + +{-| + Substitutes all mustache defined tokens (or tags) for values found in the + provided data structure. +-} +substituteValue :: Template -> Value -> Text +substituteValue = (snd .) . checkedSubstituteValue + + +{-| + Substitutes all mustache defined tokens (or tags) for values found in the + provided data structure and report any errors and warnings encountered during + substitution. + + This function always produces results, as in a fully substituted/rendered template, + it never halts on errors. It simply reports them in the first part of the tuple. + Sites with errors are usually substituted with empty string. + + The second value in the tuple is a template rendered with errors ignored. + Therefore if you must enforce that there were no errors during substitution + you must check that the error list in the first tuple value is empty. +-} +checkedSubstituteValue :: Template -> Value -> ([SubstitutionError], Text) +checkedSubstituteValue template dataStruct = + second T.concat $ runSubM + (substituteAST (ast template)) + (Context mempty dataStruct) + (partials template) + + +-- | Catch the results of running the inner substitution. +catchSubstitute :: SubM a -> SubM (a, Text) +catchSubstitute = + fmap (second (T.concat . snd)) . SubM . hideResults . listen . runSubM' + where + hideResults = censor (\(errs, _) -> (errs, [])) + + +-- | Substitute an entire 'STree' rather than just a single 'Node' +substituteAST :: STree -> SubM () +substituteAST = mapM_ substituteNode + + +-- | Main substitution function +substituteNode :: Node Text -> SubM () + +-- subtituting text +substituteNode (TextBlock t) = tellSuccess t + +-- substituting a whole section (entails a focus shift) +substituteNode (Section Implicit secSTree) = + asks fst >>= \case + Context parents focus@(Array a) + | V.null a -> pure () + | otherwise -> for_ a $ \focus' -> + let newContext = Context (focus:parents) focus' + in shiftContext newContext $ substituteAST secSTree + Context _ (Object _) -> substituteAST secSTree + Context _ v -> tellError $ InvalidImplicitSectionContextType $ showValueType v + +substituteNode (Section (NamedData secName) secSTree) = + search secName >>= \case + Just arr@(Array arrCont) -> + if V.null arrCont + then pure () + else do + Context parents focus <- asks fst + for_ arrCont $ \focus' -> + let newContext = Context (arr:focus:parents) focus' + in shiftContext newContext $ substituteAST secSTree + Just (Bool False) -> pure () + Just Null -> pure () + Just (Lambda l) -> substituteAST =<< l secSTree + Just focus' -> do + Context parents focus <- asks fst + let newContext = Context (focus:parents) focus' + shiftContext newContext $ substituteAST secSTree + Nothing -> tellError $ SectionTargetNotFound secName + +-- substituting an inverted section +substituteNode (InvertedSection Implicit _) = tellError InvertedImplicitSection +substituteNode (InvertedSection (NamedData secName) invSecSTree) = + search secName >>= \case + Just (Bool False) -> contents + Just (Array a) | V.null a -> contents + Just Null -> contents + Nothing -> contents + _ -> pure () + where + contents = mapM_ substituteNode invSecSTree + +-- substituting a variable +substituteNode (Variable _ Implicit) = asks (ctxtFocus . fst) >>= toString >>= tellSuccess +substituteNode (Variable escaped (NamedData varName)) = + maybe + (tellError $ VariableNotFound varName) + (toString >=> tellSuccess . (if escaped then escapeXMLText else id)) + =<< search varName + +-- substituting a partial +substituteNode (Partial indent pName) = do + cPartials <- asks snd + case HM.lookup pName cPartials of + Nothing -> tellError $ PartialNotFound pName + Just t -> + let ast' = handleIndent indent $ ast t + in local (second (partials t `HM.union`)) $ substituteAST ast' + + +showValueType :: Value -> String +showValueType Null = "Null" +showValueType (Object _) = "Object" +showValueType (Array _) = "Array" +showValueType (String _) = "String" +showValueType (Lambda _) = "Lambda" +showValueType (Number _) = "Number" +showValueType (Bool _) = "Bool" + + +handleIndent :: Maybe Text -> STree -> STree +handleIndent Nothing ast' = ast' +handleIndent (Just indentation) ast' = preface <> content + where + preface = [TextBlock indentation | not (T.null indentation)] + content = if T.null indentation + then ast' + else reverse $ maybe [] (uncurry (:) . first dropper) (uncons (reverse fullIndented)) + where + fullIndented = fmap (indentBy indentation) ast' + dropper (TextBlock t) = TextBlock $ + if ("\n" <> indentation) `T.isSuffixOf` t + then fromMaybe t $ T.stripSuffix indentation t + else t + dropper a = a + + +indentBy :: Text -> Node Text -> Node Text +indentBy indent p@(Partial (Just indent') name') + | T.null indent = p + | otherwise = Partial (Just (indent <> indent')) name' +indentBy indent (Partial Nothing name') = Partial (Just indent) name' +indentBy indent (TextBlock t) = TextBlock $ T.replace "\n" ("\n" <> indent) t +indentBy _ a = a + + +-- | Converts values to Text as required by the mustache standard +toString :: Value -> SubM Text +toString (String t) = pure t +toString (Number n) = pure $ either + (T.pack . show) + (T.pack . show) + (floatingOrInteger n :: Either Double Integer) +toString (Lambda l) = do + ((), res) <- catchSubstitute $ substituteAST =<< l [] + pure res +toString e = do + tellError $ DirectlyRenderedValue e + pure $ T.pack $ show e + + +instance ToMustache (Context Value -> STree -> STree) where + toMustache f = Lambda $ (<$> askContext) . flip f + +instance ToMustache (Context Value -> STree -> Text) where + toMustache = lambdaHelper id + +instance ToMustache (Context Value -> STree -> LT.Text) where + toMustache = lambdaHelper LT.toStrict + +instance ToMustache (Context Value -> STree -> String) where + toMustache = lambdaHelper T.pack + +lambdaHelper :: (r -> Text) -> (Context Value -> STree -> r) -> Value +lambdaHelper conv f = Lambda $ (<$> askContext) . wrapper + where + wrapper :: STree -> Context Value -> STree + wrapper lSTree c = [TextBlock $ conv $ f c lSTree] + +instance ToMustache (STree -> SubM Text) where + toMustache f = Lambda (fmap (pure . TextBlock) . f) diff --git a/src/Text/Mustache/Types.hs b/src/Text/Mustache/Types.hs --- a/src/Text/Mustache/Types.hs +++ b/src/Text/Mustache/Types.hs @@ -1,110 +1,125 @@ -{-| -Module : $Header$ -Description : Types and conversions -Copyright : (c) Justus Adam, 2015 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -module Text.Mustache.Types - ( - -- * Types for the Parser / Template - ASTree - , STree - , Node(..) - , DataIdentifier(..) - , Template(..) - , TemplateCache - -- * Types for the Substitution / Data - , Value(..) - , Key - -- ** Converting - , object - , (~>), (↝), (~=), (⥱) - , ToMustache, toMustache, mFromJSON, integralToMustache - -- ** Representation - , Array, Object, Pair - , SubM, askContext, askPartials - , Context(..) - ) where - - -import Control.Monad.Reader -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HM -import Data.Text (Text) -import Text.Mustache.Internal.Types - - --- | Convenience function for creating Object values. --- --- This function is supposed to be used in conjuction with the '~>' and '~=' operators. --- --- ==== __Examples__ --- --- @ --- data Address = Address { ... } --- --- instance Address ToJSON where --- ... --- --- data Person = Person { name :: String, address :: Address } --- --- instance ToMustache Person where --- toMustache (Person { name, address }) = object --- [ "name" ~> name --- , "address" ~= address --- ] --- @ --- --- Here we can see that we can use the '~>' operator for values that have --- themselves a 'ToMustache' instance, or alternatively if they lack such an --- instance but provide an instance for the 'ToJSON' typeclass we can use the --- '~=' operator. -object :: [Pair] -> Value -object = Object . HM.fromList - - --- | Map keys to values that provide a 'ToMustache' instance --- --- Recommended in conjunction with the `OverloadedStrings` extension. -(~>) :: ToMustache ω => Text -> ω -> Pair -(~>) t = (t, ) . toMustache -{-# INLINEABLE (~>) #-} -infixr 8 ~> - --- | Unicode version of '~>' -(↝) :: ToMustache ω => Text -> ω -> Pair -(↝) = (~>) -{-# INLINEABLE (↝) #-} -infixr 8 ↝ - - --- | Map keys to values that provide a 'ToJSON' instance --- --- Recommended in conjunction with the `OverloadedStrings` extension. -(~=) :: Aeson.ToJSON ι => Text -> ι -> Pair -(~=) t = (t ~>) . Aeson.toJSON -{-# INLINEABLE (~=) #-} -infixr 8 ~= - - --- | Unicode version of '~=' -(⥱) :: Aeson.ToJSON ι => Text -> ι -> Pair -(⥱) = (~=) -{-# INLINEABLE (⥱) #-} -infixr 8 ⥱ - - --- | Converts a value that can be represented as JSON to a Value. -mFromJSON :: Aeson.ToJSON ι => ι -> Value -mFromJSON = toMustache . Aeson.toJSON - - -askContext :: SubM (Context Value) -askContext = asks fst - - -askPartials :: SubM TemplateCache -askPartials = asks snd +{-| +Module : $Header$ +Description : Types and conversions +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +module Text.Mustache.Types + ( + -- * Types for the Parser / Template + ASTree + , STree + , Node (..) + , DataIdentifier (..) + , Template (..) + , TemplateCache + -- * Types for the Substitution / Data + , Value (..) + , Key + -- ** Converting + , object + , (~>) + , (↝) + , (~=) + , (⥱) + , ToMustache + , toMustache + , mFromJSON + , integralToMustache + -- ** Representation + , Array + , Object + , Pair + , SubM + , askContext + , askPartials + , Context (..) + ) where + + +import Control.Monad.Reader ( asks ) +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HM +import Data.Text ( Text ) +import Text.Mustache.Internal.Types + ( ASTree, Array, Context (..), DataIdentifier (..), Key + , Node (..), Object, Pair, STree, SubM, Template (..) + , TemplateCache, ToMustache (..), Value (..) + , integralToMustache + ) + + +-- | Convenience function for creating Object values. +-- +-- This function is supposed to be used in conjuction with the '~>' and '~=' operators. +-- +-- ==== __Examples__ +-- +-- @ +-- data Address = Address { ... } +-- +-- instance Address ToJSON where +-- ... +-- +-- data Person = Person { name :: String, address :: Address } +-- +-- instance ToMustache Person where +-- toMustache (Person { name, address }) = object +-- [ "name" ~> name +-- , "address" ~= address +-- ] +-- @ +-- +-- Here we can see that we can use the '~>' operator for values that have +-- themselves a 'ToMustache' instance, or alternatively if they lack such an +-- instance but provide an instance for the 'ToJSON' typeclass we can use the +-- '~=' operator. +object :: [Pair] -> Value +object = Object . HM.fromList + + +-- | Map keys to values that provide a 'ToMustache' instance +-- +-- Recommended in conjunction with the `OverloadedStrings` extension. +(~>) :: ToMustache ω => Text -> ω -> Pair +(~>) t = (t, ) . toMustache +{-# INLINEABLE (~>) #-} +infixr 8 ~> + +-- | Unicode version of '~>' +(↝) :: ToMustache ω => Text -> ω -> Pair +(↝) = (~>) +{-# INLINEABLE (↝) #-} +infixr 8 ↝ + + +-- | Map keys to values that provide a 'ToJSON' instance +-- +-- Recommended in conjunction with the `OverloadedStrings` extension. +(~=) :: Aeson.ToJSON ι => Text -> ι -> Pair +(~=) t = (t ~>) . Aeson.toJSON +{-# INLINEABLE (~=) #-} +infixr 8 ~= + + +-- | Unicode version of '~=' +(⥱) :: Aeson.ToJSON ι => Text -> ι -> Pair +(⥱) = (~=) +{-# INLINEABLE (⥱) #-} +infixr 8 ⥱ + + +-- | Converts a value that can be represented as JSON to a Value. +mFromJSON :: Aeson.ToJSON ι => ι -> Value +mFromJSON = toMustache . Aeson.toJSON + + +askContext :: SubM (Context Value) +askContext = asks fst + + +askPartials :: SubM TemplateCache +askPartials = asks snd diff --git a/test/integration/Language.hs b/test/integration/Language.hs --- a/test/integration/Language.hs +++ b/test/integration/Language.hs @@ -1,110 +1,122 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UnicodeSyntax #-} -module Main where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Compression.GZip as GZip -import Control.Applicative ((<$>), (<*>)) -import Control.Lens -import Control.Monad -import Data.ByteString.Lazy (toStrict) -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HM (HashMap, empty, - traverseWithKey) -import Data.List -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Yaml as Y (FromJSON, Value (..), decode, - parseJSON, (.!=), (.:), (.:?)) -import Network.Wreq -import System.FilePath -import Test.Hspec -import Text.Mustache - - -langspecs :: [String] -langspecs = - [ "https://codeload.github.com/andrewthad/spec/legacy.tar.gz/add_list_context_check" - , "https://codeload.github.com/mustache/spec/tar.gz/v1.1.3" - ] - - -data LangSpecFile = LangSpecFile - { overview :: String - , tests :: [LangSpecTest] - } - - -data LangSpecTest = LangSpecTest - { name :: String - , specDescription :: String - , specData :: Y.Value - , template :: T.Text - , expected :: T.Text - , testPartials :: HM.HashMap String T.Text - } - - -instance FromJSON LangSpecFile where - parseJSON (Y.Object o) = LangSpecFile - <$> o .: "overview" - <*> o .: "tests" - parseJSON _ = mzero - - -instance FromJSON LangSpecTest where - parseJSON (Y.Object o) = LangSpecTest - <$> o .: "name" - <*> o .: "desc" - <*> o .: "data" - <*> o .: "template" - <*> o .: "expected" - <*> o .:? "partials" .!= HM.empty - parseJSON _ = mzero - - -getOfficialSpecRelease :: String -> IO [(String, LangSpecFile)] -getOfficialSpecRelease releaseURL = do - res <- get releaseURL - let archive = Tar.read $ GZip.decompress (res ^. responseBody) - return $ Tar.foldEntries handleEntry [] (error . show) archive - where - handleEntry e acc = - case content of - Tar.NormalFile f _ - | takeExtension filename `elem` [".yml", ".yaml"] - && not ("~" `isPrefixOf` takeFileName filename) -> - (filename, fromMaybe (error $ "Error parsing spec file " ++ filename) $ decode $ toStrict f):acc - _ -> acc - where - filename = Tar.entryPath e - content = Tar.entryContent e - - -testOfficialLangSpec :: [(String, LangSpecFile)] -> Spec -testOfficialLangSpec testfiles = - for_ testfiles $ \(filename, LangSpecFile { tests }) -> - describe ("File: " ++ takeFileName filename) $ - for_ tests $ \(LangSpecTest { .. }) -> - it ("Name: " ++ name ++ " Description: " ++ specDescription) $ - let - compiled = do - partials' <- HM.traverseWithKey compileTemplate testPartials - template' <- compileTemplate name template - return $ template' { partials = partials' } - in - case compiled of - Left m -> expectationFailure $ show m - Right tmp -> - substituteValue tmp (toMustache specData) `shouldBe` expected - - -main :: IO () -main = - void $ do - specs <- mapM getOfficialSpecRelease langspecs - hspec $ mapM_ testOfficialLangSpec specs +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnicodeSyntax #-} +module Main + ( main + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import Control.Applicative ( (<$>), (<*>) ) +import Control.Exception ( Exception (..) ) +import Control.Lens ( (^.) ) +import Control.Monad ( mzero, void ) +import Data.ByteString.Lazy ( toStrict ) +import Data.Foldable ( for_ ) +import qualified Data.HashMap.Strict as HM +import Data.List ( isPrefixOf ) +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T +import Data.Yaml + ( FromJSON, Value (..), (.!=), (.:), (.:?), decodeEither' + , parseJSON + ) +import Network.Wreq ( get, responseBody ) +import System.FilePath ( takeExtension, takeFileName ) +import Test.Hspec + ( Spec, describe, expectationFailure, hspec, shouldBe, it ) +import Text.Mustache + ( Template (..), compileTemplate, substituteValue, toMustache + ) + +langspecs :: [String] +langspecs = + [ "https://codeload.github.com/andrewthad/spec/legacy.tar.gz/add_list_context_check" + , "https://codeload.github.com/mustache/spec/tar.gz/v1.1.3" + ] + + +data LangSpecFile = LangSpecFile + { overview :: String + , tests :: [LangSpecTest] + } + + +data LangSpecTest = LangSpecTest + { name :: String + , specDescription :: String + , specData :: Value + , template :: T.Text + , expected :: T.Text + , testPartials :: HM.HashMap String T.Text + } + + +instance FromJSON LangSpecFile where + parseJSON (Object o) = LangSpecFile + <$> o .: "overview" + <*> o .: "tests" + parseJSON _ = mzero + + +instance FromJSON LangSpecTest where + parseJSON (Object o) = LangSpecTest + <$> o .: "name" + <*> o .: "desc" + <*> o .: "data" + <*> o .: "template" + <*> o .: "expected" + <*> o .:? "partials" .!= HM.empty + parseJSON _ = mzero + + +getOfficialSpecRelease :: String -> IO [(String, LangSpecFile)] +getOfficialSpecRelease releaseURL = do + res <- get releaseURL + let archive = Tar.read $ GZip.decompress (res ^. responseBody) + pure $ Tar.foldEntries handleEntry [] (error . show) archive + where + handleEntry e acc = + case content of + Tar.NormalFile f _ + | takeExtension filename `elem` [".yml", ".yaml"] + && not ("~" `isPrefixOf` takeFileName filename) -> + ( filename + , case decodeEither' $ toStrict f of + Left e -> error $ + "Error parsing spec file " + ++ filename + ++ ": " + ++ displayException e + Right spec -> spec + ) : acc + _ -> acc + where + filename = Tar.entryPath e + content = Tar.entryContent e + + +testOfficialLangSpec :: [(String, LangSpecFile)] -> Spec +testOfficialLangSpec testfiles = + for_ testfiles $ \(filename, LangSpecFile { tests }) -> + describe ("File: " ++ takeFileName filename) $ + for_ tests $ \(LangSpecTest { .. }) -> + it ("Name: " ++ name ++ " Description: " ++ specDescription) $ + let + compiled = do + partials' <- HM.traverseWithKey compileTemplate testPartials + template' <- compileTemplate name template + pure $ template' { partials = partials' } + in + case compiled of + Left m -> expectationFailure $ show m + Right tmp -> + substituteValue tmp (toMustache specData) `shouldBe` expected + + +main :: IO () +main = + void $ do + specs <- mapM getOfficialSpecRelease langspecs + hspec $ mapM_ testOfficialLangSpec specs diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -1,254 +1,267 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module Main where - - -import Control.Applicative ((<$>), (<*>)) -import Data.Either -import Data.Function (on) -import Data.Monoid -import qualified Data.Text as T -import System.IO.Unsafe (unsafePerformIO) -import Test.Hspec -import Text.Mustache -import Text.Mustache.Compile -import Text.Mustache.Parser -import Text.Mustache.Types - - -escaped :: Bool -escaped = True -unescaped :: Bool -unescaped = False - - -parserSpec :: Spec -parserSpec = - describe "mustacheParser" $ do - let lparse = parse "testsuite" - let returnedOne = return . return - - let text = "test12356p0--=-34{}jnv,\n" - - it "parses text" $ - lparse text `shouldBe` returnedOne (TextBlock text) - - it "parses a variable" $ - lparse "{{name}}" `shouldBe` returnedOne (Variable escaped (NamedData ["name"])) - - it "parses a variable with whitespace" $ - lparse "{{ name }}" `shouldBe` returnedOne (Variable escaped (NamedData ["name"])) - - it "allows '-' in variable names" $ - lparse "{{ name-name }}" `shouldBe` - returnedOne (Variable True (NamedData ["name-name"])) - - it "allows '_' in variable names" $ - lparse "{{ name_name }}" `shouldBe` - returnedOne (Variable True (NamedData ["name_name"])) - - it "parses a variable unescaped with {{{}}}" $ - lparse "{{{name}}}" `shouldBe` returnedOne (Variable unescaped (NamedData ["name"])) - - it "parses a variable unescaped with {{{}}} with whitespace" $ - lparse "{{{ name }}}" `shouldBe` - returnedOne (Variable False (NamedData ["name"])) - - it "parses a variable unescaped with &" $ - lparse "{{&name}}" `shouldBe` returnedOne (Variable unescaped (NamedData ["name"])) - - it "parses a variable unescaped with & with whitespace" $ - lparse "{{& name }}" `shouldBe` - returnedOne (Variable False (NamedData ["name"])) - - it "parses a partial" $ - lparse "{{>myPartial}}" `shouldBe` - returnedOne (Partial (Just "") "myPartial") - - it "parses a partial with whitespace" $ - lparse "{{> myPartial }}" `shouldBe` - returnedOne (Partial (Just "") "myPartial") - - it "parses the an empty section" $ - lparse "{{#section}}{{/section}}" `shouldBe` - returnedOne (Section (NamedData ["section"]) mempty) - - it "parses the an empty section with whitespace" $ - lparse "{{# section }}{{/ section }}" `shouldBe` - returnedOne (Section (NamedData ["section"]) mempty) - - it "parses a delimiter change" $ - lparse "{{=<< >>=}}<>{{var}}" `shouldBe` - return [Variable True (NamedData ["var"]), TextBlock "{{var}}"] - - it "parses a delimiter change with whitespace" $ - lparse "{{=<< >>=}}<< var >>{{var}}" `shouldBe` - return [Variable True (NamedData ["var"]), TextBlock "{{var}}"] - - it "parses two subsequent delimiter changes" $ - lparse "{{=(( ))=}}(( var ))((=-- $-=))--#section$---/section$-" `shouldBe` - return [Variable True (NamedData ["var"]), Section (NamedData ["section"]) []] - - it "propagates a delimiter change from a nested scope" $ - lparse "{{#section}}{{=<< >>=}}<><>" `shouldBe` - return [Section (NamedData ["section"]) [], Variable escaped (NamedData ["var"])] - - it "fails if the tag contains illegal characters" $ - lparse "{{#&}}" `shouldSatisfy` isLeft - - it "parses a nested variable" $ - lparse "{{ name.val }}" `shouldBe` returnedOne (Variable escaped (NamedData ["name", "val"])) - - it "parses a variable containing whitespace" $ - lparse "{{ val space }}" `shouldBe` returnedOne (Variable escaped (NamedData ["val space"])) - - -substituteSpec :: Spec -substituteSpec = - describe "substitute" $ do - - let toTemplate ast' = Template "testsuite" ast' mempty - - it "substitutes a html escaped value for a variable" $ - substitute - (toTemplate [Variable escaped (NamedData ["name"])]) - (object ["name" ~> ("\" ' < > &" :: T.Text)]) - `shouldBe` "" ' < > &" - - it "substitutes raw value for an unescaped variable" $ - substitute - (toTemplate [Variable unescaped (NamedData ["name"])]) - (object ["name" ~> ("\" ' < > &" :: T.Text)]) - `shouldBe` "\" ' < > &" - - it "substitutes a section when the key is present (and an empty object)" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> object []]) - `shouldBe` "t" - - it "substitutes a section when the key is present (and 'true')" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> True]) - `shouldBe` "t" - - it "substitutes a section once when the key is present and a singleton list" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> ["True" :: T.Text]]) - `shouldBe` "t" - - it "substitutes a section twice when the key is present and a list with two items" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> (["True", "False"] :: [T.Text])]) - `shouldBe` "tt" - - it "substitutes a section twice when the key is present and a list with two\ - \ objects, changing the scope to each object" $ - substitute - (toTemplate [Section (NamedData ["section"]) [Variable escaped (NamedData ["t"])]]) - (object - [ "section" ~> - [ object ["t" ~> ("var1" :: T.Text)] - , object ["t" ~> ("var2" :: T.Text)] - ] - ]) - `shouldBe` "var1var2" - - it "does not substitute a section when the key is not present" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object []) - `shouldBe` "" - - it "does not substitute a section when the key is present (and 'false')" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> False]) - `shouldBe` "" - - it "does not substitute a section when the key is present (and null)" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> Null]) - `shouldBe` "" - - it "does not substitute a section when the key is present (and empty list)" $ - substitute - (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) - (object ["section" ~> ([] :: [T.Text])]) - `shouldBe` "" - - it "substitutes a lambda by applying lambda to contained text" $ - substitute - (toTemplate [Section (NamedData ["lambda"]) [TextBlock "t"]]) - (object ["lambda" ~> (overText T.toUpper)]) - `shouldBe` "T" - - it "substitutes a lambda by applying lambda to the nested substitution results" $ - substitute - (toTemplate [Section (NamedData ["lambda"]) [TextBlock "t", Variable escaped (NamedData ["inner"])]]) - (object [ "lambda" ~> (overText T.toUpper) - , "inner" ~> ("var" :: T.Text) - ]) - `shouldBe` "TVAR" - - it "substitutes a lambda used directly as if applied to empty block" $ - substitute - (toTemplate [Variable escaped (NamedData ["lambda"])]) - (object ["lambda" ~> (Lambda $ \[] -> return [TextBlock "T"])]) - `shouldBe` "T" - - it "substitutes a nested section" $ - substitute - (toTemplate [Variable escaped (NamedData ["outer", "inner"])]) - (object - [ "outer" ~> object ["inner" ~> ("success" :: T.Text)] - , "inner" ~> ("error" :: T.Text) - ] - ) - `shouldBe` "success" - - -converterSpec :: Spec -converterSpec = - describe "toMustache" $ - it "converts a String" $ - toMustache ("My String" :: String) `shouldSatisfy` \case (String "My String") -> True; _ -> False - --- This is a one-off instance to define how we want the Spec to compare templates -instance Eq Template where - (==) = (==) `on` ast - -compileTimeSpec :: Spec -compileTimeSpec = - describe "compileTimeCompiling" $ do - - it "creates compiled templates from a QuasiQuoter" $ - Right [mustache|This {{ template }} was injected at compile time with a quasiquoter|] `shouldBe` - compileTemplate "Template Name" "This {{ template }} was injected at compile time with a quasiquoter" - - it "creates compiled templates from an embedded file" $ - Right $(embedTemplate ["test/unit/examples"] "test-template.txt.mustache") `shouldBe` - compileTemplate "Template Name" "This {{ template }} was injected at compile time with an embedded file\n" - - it "creates compiled templates from a single embedded file" $ - Right $(embedSingleTemplate "test/unit/examples/test-template.txt.mustache") `shouldBe` - compileTemplate "Template Name" "This {{ template }} was injected at compile time with an embedded file\n" - - it "creates compiled templates from an embedded file containing partials" $ - Right $(embedTemplate ["test/unit/examples", "test/unit/examples/partials"] "test-template-partials.txt.mustache") `shouldBe` - unsafePerformIO (automaticCompile ["test/unit/examples", "test/unit/examples/partials"] "test-template-partials.txt.mustache") - -main :: IO () -main = hspec $ do - parserSpec - substituteSpec - converterSpec - compileTimeSpec +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Main + ( main + ) where + + +import Control.Applicative ( (<$>), (<*>) ) +import Data.Either ( isLeft ) +import Data.Function ( on ) +import qualified Data.Text as T +import System.IO.Unsafe ( unsafePerformIO ) +import Test.Hspec + ( Spec, describe, hspec, it, shouldBe, shouldSatisfy ) +import Text.Mustache + ( Template (..), ToMustache (..), (~>), automaticCompile + , compileTemplate, object, overText, substitute + ) +import Text.Mustache.Compile + ( embedTemplate, embedSingleTemplate, mustache ) +import Text.Mustache.Parser ( parse ) +import Text.Mustache.Types + ( DataIdentifier (..), Node (..), Value (..) ) + + +escaped :: Bool +escaped = True +unescaped :: Bool +unescaped = False + + +parserSpec :: Spec +parserSpec = + describe "mustacheParser" $ do + let lparse = parse "testsuite" + let returnedOne = pure . pure + + let text = "test12356p0--=-34{}jnv,\n" + + it "parses text" $ + lparse text `shouldBe` returnedOne (TextBlock text) + + it "parses a variable" $ + lparse "{{name}}" `shouldBe` returnedOne (Variable escaped (NamedData ["name"])) + + it "parses a variable with whitespace" $ + lparse "{{ name }}" `shouldBe` returnedOne (Variable escaped (NamedData ["name"])) + + it "allows '-' in variable names" $ + lparse "{{ name-name }}" `shouldBe` + returnedOne (Variable True (NamedData ["name-name"])) + + it "allows '_' in variable names" $ + lparse "{{ name_name }}" `shouldBe` + returnedOne (Variable True (NamedData ["name_name"])) + + it "parses a variable unescaped with {{{}}}" $ + lparse "{{{name}}}" `shouldBe` returnedOne (Variable unescaped (NamedData ["name"])) + + it "parses a variable unescaped with {{{}}} with whitespace" $ + lparse "{{{ name }}}" `shouldBe` + returnedOne (Variable False (NamedData ["name"])) + + it "parses a variable unescaped with &" $ + lparse "{{&name}}" `shouldBe` returnedOne (Variable unescaped (NamedData ["name"])) + + it "parses a variable unescaped with & with whitespace" $ + lparse "{{& name }}" `shouldBe` + returnedOne (Variable False (NamedData ["name"])) + + it "parses a partial" $ + lparse "{{>myPartial}}" `shouldBe` + returnedOne (Partial (Just "") "myPartial") + + it "parses a partial with whitespace" $ + lparse "{{> myPartial }}" `shouldBe` + returnedOne (Partial (Just "") "myPartial") + + it "parses the an empty section" $ + lparse "{{#section}}{{/section}}" `shouldBe` + returnedOne (Section (NamedData ["section"]) mempty) + + it "parses the an empty section with whitespace" $ + lparse "{{# section }}{{/ section }}" `shouldBe` + returnedOne (Section (NamedData ["section"]) mempty) + + it "parses a delimiter change" $ + lparse "{{=<< >>=}}<>{{var}}" `shouldBe` + pure [Variable True (NamedData ["var"]), TextBlock "{{var}}"] + + it "parses a delimiter change with whitespace" $ + lparse "{{=<< >>=}}<< var >>{{var}}" `shouldBe` + pure [Variable True (NamedData ["var"]), TextBlock "{{var}}"] + + it "parses two subsequent delimiter changes" $ + lparse "{{=(( ))=}}(( var ))((=-- $-=))--#section$---/section$-" `shouldBe` + pure [Variable True (NamedData ["var"]), Section (NamedData ["section"]) []] + + it "propagates a delimiter change from a nested scope" $ + lparse "{{#section}}{{=<< >>=}}<><>" `shouldBe` + pure [Section (NamedData ["section"]) [], Variable escaped (NamedData ["var"])] + + it "fails if the tag contains illegal characters" $ + lparse "{{#&}}" `shouldSatisfy` isLeft + + it "parses a nested variable" $ + lparse "{{ name.val }}" `shouldBe` returnedOne (Variable escaped (NamedData ["name", "val"])) + + it "parses a variable containing whitespace" $ + lparse "{{ val space }}" `shouldBe` returnedOne (Variable escaped (NamedData ["val space"])) + + +substituteSpec :: Spec +substituteSpec = + describe "substitute" $ do + + let toTemplate ast' = Template "testsuite" ast' mempty + + it "substitutes a html escaped value for a variable" $ + substitute + (toTemplate [Variable escaped (NamedData ["name"])]) + (object ["name" ~> ("\" ' < > &" :: T.Text)]) + `shouldBe` "" ' < > &" + + it "substitutes raw value for an unescaped variable" $ + substitute + (toTemplate [Variable unescaped (NamedData ["name"])]) + (object ["name" ~> ("\" ' < > &" :: T.Text)]) + `shouldBe` "\" ' < > &" + + it "substitutes a section when the key is present (and an empty object)" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> object []]) + `shouldBe` "t" + + it "substitutes a section when the key is present (and 'true')" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> True]) + `shouldBe` "t" + + it "substitutes a section once when the key is present and a singleton list" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> ["True" :: T.Text]]) + `shouldBe` "t" + + it "substitutes a section twice when the key is present and a list with two items" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> (["True", "False"] :: [T.Text])]) + `shouldBe` "tt" + + it "substitutes a section twice when the key is present and a list with two\ + \ objects, changing the scope to each object" $ + substitute + (toTemplate [Section (NamedData ["section"]) [Variable escaped (NamedData ["t"])]]) + (object + [ "section" ~> + [ object ["t" ~> ("var1" :: T.Text)] + , object ["t" ~> ("var2" :: T.Text)] + ] + ]) + `shouldBe` "var1var2" + + it "substitutes an inverse section when the key is present (and null)" $ + substitute + (toTemplate [InvertedSection (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> Null]) + `shouldBe` "t" + + it "does not substitute a section when the key is not present" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object []) + `shouldBe` "" + + it "does not substitute a section when the key is present (and 'false')" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> False]) + `shouldBe` "" + + it "does not substitute a section when the key is present (and null)" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> Null]) + `shouldBe` "" + + it "does not substitute a section when the key is present (and empty list)" $ + substitute + (toTemplate [Section (NamedData ["section"]) [TextBlock "t"]]) + (object ["section" ~> ([] :: [T.Text])]) + `shouldBe` "" + + it "substitutes a lambda by applying lambda to contained text" $ + substitute + (toTemplate [Section (NamedData ["lambda"]) [TextBlock "t"]]) + (object ["lambda" ~> overText T.toUpper]) + `shouldBe` "T" + + it "substitutes a lambda by applying lambda to the nested substitution results" $ + substitute + (toTemplate [Section (NamedData ["lambda"]) [TextBlock "t", Variable escaped (NamedData ["inner"])]]) + (object [ "lambda" ~> overText T.toUpper + , "inner" ~> ("var" :: T.Text) + ]) + `shouldBe` "TVAR" + + it "substitutes a lambda used directly as if applied to empty block" $ + substitute + (toTemplate [Variable escaped (NamedData ["lambda"])]) + (object ["lambda" ~> Lambda (\[] -> pure [TextBlock "T"])]) + `shouldBe` "T" + + it "substitutes a nested section" $ + substitute + (toTemplate [Variable escaped (NamedData ["outer", "inner"])]) + (object + [ "outer" ~> object ["inner" ~> ("success" :: T.Text)] + , "inner" ~> ("error" :: T.Text) + ] + ) + `shouldBe` "success" + + +converterSpec :: Spec +converterSpec = + describe "toMustache" $ + it "converts a String" $ + toMustache ("My String" :: String) `shouldSatisfy` \case (String "My String") -> True; _ -> False + +-- This is a one-off instance to define how we want the Spec to compare templates +instance Eq Template where + (==) = (==) `on` ast + +compileTimeSpec :: Spec +compileTimeSpec = + describe "compileTimeCompiling" $ do + + it "creates compiled templates from a QuasiQuoter" $ + Right [mustache|This {{ template }} was injected at compile time with a quasiquoter|] `shouldBe` + compileTemplate "Template Name" "This {{ template }} was injected at compile time with a quasiquoter" + + it "creates compiled templates from an embedded file" $ + Right $(embedTemplate ["test/unit/examples"] "test-template.txt.mustache") `shouldBe` + compileTemplate "Template Name" "This {{ template }} was injected at compile time with an embedded file\n" + + it "creates compiled templates from a single embedded file" $ + Right $(embedSingleTemplate "test/unit/examples/test-template.txt.mustache") `shouldBe` + compileTemplate "Template Name" "This {{ template }} was injected at compile time with an embedded file\n" + + it "creates compiled templates from an embedded file containing partials" $ + Right $(embedTemplate ["test/unit/examples", "test/unit/examples/partials"] "test-template-partials.txt.mustache") `shouldBe` + unsafePerformIO (automaticCompile ["test/unit/examples", "test/unit/examples/partials"] "test-template-partials.txt.mustache") + +main :: IO () +main = hspec $ do + parserSpec + substituteSpec + converterSpec + compileTimeSpec