diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UnicodeSyntax #-} +module Main (main) where + + +import Data.Aeson (Value, eitherDecode) +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 Prelude.Unicode +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 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,5 +1,5 @@ name: mustache -version: 1.0 +version: 1.0.1 synopsis: A mustache template parser library. description: Allows parsing and rendering template files with mustache markup. See the @@ -30,7 +30,7 @@ type: git branch: master location: git://github.com/JustusAdam/mustache.git - tag: v1.0 + tag: v1.0.1 @@ -59,7 +59,7 @@ , scientific , base-unicode-symbols , containers - hs-source-dirs: src/lib + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -77,7 +77,8 @@ , filepath , base-unicode-symbols default-language: Haskell2010 - hs-source-dirs: src/bin + ghc-options: -threaded -Wall + hs-source-dirs: app test-suite unit-tests diff --git a/src/Text/Mustache.hs b/src/Text/Mustache.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mustache.hs @@ -0,0 +1,182 @@ +{-| +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 @searchSpache@, 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 + + -- ** Specialized + + , substituteValue + + -- ** Data Conversion + , ToMustache, toMustache, object, (~>), (~=) + ) where + + + +import Text.Mustache.Compile +import Text.Mustache.Render +import Text.Mustache.Types diff --git a/src/Text/Mustache/Compile.hs b/src/Text/Mustache/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mustache/Compile.hs @@ -0,0 +1,149 @@ +{-| +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 UnicodeSyntax #-} +module Text.Mustache.Compile + ( automaticCompile, localAutomaticCompile, TemplateCache, compileTemplateWithCache + , compileTemplate, cacheFromList, getPartials, getFile + ) where + + +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.State +import Control.Monad.Trans.Either +import Control.Monad.Unicode +import Data.Bool +import Data.HashMap.Strict as HM +import Data.Monoid.Unicode ((∅)) +import Data.Text hiding (concat, find, map, uncons) +import qualified Data.Text.IO as TIO +import Prelude.Unicode +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 (∅) + + +-- | 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 = + runEitherT $ evalStateT (compile' initName) $ flattenPartials templates + where + compile' ∷ FilePath + → StateT + (HM.HashMap String Template) + (EitherT 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 $ hoistEither $ 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 'TemplateChache' +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') (∅)) ∘ 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' _ = (∅) + + +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 → EitherT 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 + + +-- 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 new file mode 100644 --- /dev/null +++ b/src/Text/Mustache/Internal.hs @@ -0,0 +1,42 @@ +{-| +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. +-} +{-# LANGUAGE UnicodeSyntax #-} +module Text.Mustache.Internal (uncons, escapeXMLText) where + + +import Data.Char (ord) +import qualified Data.IntMap as IntMap +import qualified Data.Text as T +import Prelude.Unicode + + +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", "\"") + , ("amp" , "&") + , ("lt" , "<") + , ("gt" , ">") + ] diff --git a/src/Text/Mustache/Parser.hs b/src/Text/Mustache/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mustache/Parser.hs @@ -0,0 +1,315 @@ +{-| +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 #-} +{-# LANGUAGE UnicodeSyntax #-} +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 Control.Monad.Unicode +import Data.Char (isAlphaNum, isSpace) +import Data.Functor ((<$>)) +import Data.List (nub) +import Data.Monoid.Unicode ((∅), (⊕)) +import Data.Text as T (Text, null, pack) +import Prelude as Prel +import Prelude.Unicode +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 ("", "") (∅) 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 = (∅) } + 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 (∅)) + , SectionEnd + <$> (try (char sectionEnd) ≫ genParseTagEnd (∅)) + , Tag ∘ Variable False + <$> (try (char unescape1) ≫ genParseTagEnd (∅)) + , 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 (∅) ≫= \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 (∅) + ] + where + parseDelimChange = do + (MustacheState { sDelimiters = ( _, end )}) ← getState + spaces + delim1 ← allowedDelimiterCharacter `manyTill` space + spaces + delim2 ← allowedDelimiterCharacter `manyTill` try (spaces ≫ string (delimiterChange : end)) + when (delim1 ≡ (∅) ∨ delim2 ≡ (∅)) + $ 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 (∅) <$> (spaces ≫ string nEnd)) + return $ pack one : others + spaces + (try (char implicitIterator) ≫ spaces ≫ string nEnd ≫ return Implicit) + <|> (NamedData <$> parseOne) diff --git a/src/Text/Mustache/Render.hs b/src/Text/Mustache/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mustache/Render.hs @@ -0,0 +1,184 @@ +{-| +Module : $Header$ +Description : Functions for rendering mustache templates. +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnicodeSyntax #-} +module Text.Mustache.Render + ( + -- * Substitution + substitute, substituteValue + -- * Working with Context + , Context(..), search, innerSearch + -- * Util + , toString + ) where + + +import Control.Applicative ((<$>), (<|>)) +import Control.Arrow (first) +import Control.Monad +import Control.Monad.Unicode +import Data.Foldable (fold) +import Data.HashMap.Strict as HM hiding (map) +import Data.Maybe (fromMaybe) +import Data.Monoid.Unicode +import Data.Scientific (floatingOrInteger) +import Data.Text as T (Text, isSuffixOf, null, pack, + replace, stripSuffix) +import qualified Data.Vector as V +import Prelude hiding (length, lines, unlines) +import Prelude.Unicode +import Text.Mustache.Internal +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 κ ⇒ Template → κ → Text +substitute t = substituteValue t ∘ toMustache + + +{-| + Substitutes all mustache defined tokens (or tags) for values found in the + provided data structure. +-} +substituteValue ∷ Template → Value → Text +substituteValue (Template { ast = cAst, partials = cPartials }) dataStruct = + joinSubstituted (substitute' (Context (∅) dataStruct)) cAst + where + joinSubstituted f = fold ∘ fmap f + + -- Main substitution function + substitute' ∷ Context Value → Node Text → Text + + -- subtituting text + substitute' _ (TextBlock t) = t + + -- substituting a whole section (entails a focus shift) + substitute' (Context parents focus@(Array a)) (Section Implicit secSTree) + | V.null a = (∅) + | otherwise = flip joinSubstituted a $ \focus' → + let + newContext = Context (focus:parents) focus' + in + joinSubstituted (substitute' newContext) secSTree + substitute' context@(Context _ (Object _)) (Section Implicit secSTree) = + joinSubstituted (substitute' context) secSTree + substitute' _ (Section Implicit _) = (∅) + substitute' context@(Context parents focus) (Section (NamedData secName) secSTree) = + case search context secName of + Just arr@(Array arrCont) → + if V.null arrCont + then (∅) + else flip joinSubstituted arrCont $ \focus' → + let + newContext = Context (arr:focus:parents) focus' + in + joinSubstituted (substitute' newContext) secSTree + Just (Bool False) → (∅) + Just (Lambda l) → joinSubstituted (substitute' context) (l context secSTree) + Just focus' → + let + newContext = Context (focus:parents) focus' + in + joinSubstituted (substitute' newContext) secSTree + Nothing → (∅) + + -- substituting an inverted section + substitute' _ (InvertedSection Implicit _ ) = (∅) + substitute' context (InvertedSection (NamedData secName) invSecSTree) = + case search context secName of + Just (Bool False) → contents + Just (Array a) | V.null a → contents + Nothing → contents + _ → (∅) + where + contents = joinSubstituted (substitute' context) invSecSTree + + -- substituting a variable + substitute' (Context _ current) (Variable _ Implicit) = toString current + substitute' context (Variable escaped (NamedData varName)) = + maybe + (∅) + (if escaped then escapeXMLText else id) + $ toString <$> search context varName + + -- substituting a partial + substitute' context (Partial indent pName) = + maybe + (∅) + (joinSubstituted (substitute' context) ∘ handleIndent indent ∘ ast) + $ HM.lookup pName cPartials + + +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 + let + 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 + in + reverse $ fromMaybe [] (uncurry (:) ∘ first dropper <$> uncons (reverse fullIndented)) + + +-- | 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 ∷ Context Value → [Key] → Maybe Value +search _ [] = Nothing +search ctx keys@(_:nextKeys) = go ctx keys ≫= innerSearch nextKeys + where + go _ [] = Nothing + go (Context parents focus) val@(x:_) = + ( case focus of + (Object o) → HM.lookup x o + _ → Nothing + ) + <|> ( do + (newFocus, newParents) ← uncons parents + go (Context newParents newFocus) val + ) + +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 + + +-- | 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 + + +-- | Converts values to Text as required by the mustache standard +toString ∷ Value → Text +toString (String t) = t +toString (Number n) = either (pack ∘ show) (pack ∘ show) (floatingOrInteger n ∷ Either Double Integer) +toString e = pack $ show e diff --git a/src/Text/Mustache/Types.hs b/src/Text/Mustache/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mustache/Types.hs @@ -0,0 +1,381 @@ +{-| +Module : $Header$ +Description : Types and conversions +Copyright : (c) Justus Adam, 2015 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE BangPatterns #-} +module Text.Mustache.Types + ( + -- * Types for the Parser / Template + STree + , Template(..) + , Node(..) + , DataIdentifier(..) + -- * Types for the Substitution / Data + , Value(..) + , Key + -- ** Converting + , object + , (~>), (↝), (~=), (⥱) + , ToMustache, toMustache, mFromJSON + -- ** Representation + , Array, Object, Pair + , Context(..) + , TemplateCache + ) where + + +import qualified Data.Aeson as Aeson +import Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Map as Map +import Data.Scientific +import Data.Text +import qualified Data.Text.Lazy as LT +import qualified Data.Vector as V +import Prelude.Unicode + +-- | 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 [α] α + deriving (Eq, Show, Ord) + +-- | Internal value representation +data Value + = Object !Object + | Array !Array + | Number !Scientific + | String !Text + | Lambda (Context Value → STree → 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" + +-- | Conversion class +class ToMustache ω where + toMustache ∷ ω → Value + listToMustache ∷ [ω] → Value + listToMustache = Array ∘ V.fromList ∘ fmap toMustache + +instance ToMustache Float where + toMustache = Number ∘ fromFloatDigits + +instance ToMustache Double where + toMustache = Number ∘ fromFloatDigits + +instance ToMustache Integer where + toMustache = Number ∘ fromInteger + +instance ToMustache Int where + toMustache = toMustache . toInteger + +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 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 (V.Vector ω) where + toMustache = toMustache ∘ 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 = toMustache ∘ 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 (Context Value → STree → STree) where + toMustache = Lambda + +instance ToMustache (Context Value → STree → Text) where + toMustache = lambdaInstanceHelper id + +instance ToMustache (Context Value → STree → LT.Text) where + toMustache = lambdaInstanceHelper LT.toStrict + +instance ToMustache (Context Value → STree → String) where + toMustache = lambdaInstanceHelper pack + +lambdaInstanceHelper :: (a -> Text) -> (Context Value -> STree -> a) -> Value +lambdaInstanceHelper conv f = Lambda wrapper + where + wrapper ∷ Context Value → STree → STree + wrapper c lSTree = return ∘ TextBlock $ conv $ f c lSTree + +instance ToMustache (STree → STree) where + toMustache f = toMustache (const f ∷ Context Value → STree → STree) + +instance ToMustache (STree → Text) where + toMustache f = toMustache wrapper + where + wrapper ∷ Context Value → STree → STree + wrapper _ = (return ∘ TextBlock) ∘ f + +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 = toMustache ∘ HS.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 + ] + +-- | 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 + + +-- | 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) diff --git a/src/bin/Main.hs b/src/bin/Main.hs deleted file mode 100644 --- a/src/bin/Main.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE UnicodeSyntax #-} -module Main (main) where - - -import Data.Aeson (Value, eitherDecode) -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 Prelude.Unicode -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 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/src/lib/Text/Mustache.hs b/src/lib/Text/Mustache.hs deleted file mode 100644 --- a/src/lib/Text/Mustache.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -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 @searchSpache@, 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 - - -- ** Specialized - - , substituteValue - - -- ** Data Conversion - , ToMustache, toMustache, object, (~>), (~=) - ) where - - - -import Text.Mustache.Compile -import Text.Mustache.Render -import Text.Mustache.Types diff --git a/src/lib/Text/Mustache/Compile.hs b/src/lib/Text/Mustache/Compile.hs deleted file mode 100644 --- a/src/lib/Text/Mustache/Compile.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -module Text.Mustache.Compile - ( automaticCompile, localAutomaticCompile, TemplateCache, compileTemplateWithCache - , compileTemplate, cacheFromList, getPartials, getFile - ) where - - -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Except -import Control.Monad.State -import Control.Monad.Trans.Either -import Control.Monad.Unicode -import Data.Bool -import Data.HashMap.Strict as HM -import Data.Monoid.Unicode ((∅)) -import Data.Text hiding (concat, find, map, uncons) -import qualified Data.Text.IO as TIO -import Prelude.Unicode -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 (∅) - - --- | 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 = - runEitherT $ evalStateT (compile' initName) $ flattenPartials templates - where - compile' ∷ FilePath - → StateT - (HM.HashMap String Template) - (EitherT 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 $ hoistEither $ 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 'TemplateChache' -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') (∅)) ∘ 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' _ = (∅) - - -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 → EitherT 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 - - --- ERRORS - -fileNotFound ∷ FilePath → ParseError -fileNotFound fp = newErrorMessage (Message $ printf "Template file '%s' not found" fp) (initialPos fp) diff --git a/src/lib/Text/Mustache/Internal.hs b/src/lib/Text/Mustache/Internal.hs deleted file mode 100644 --- a/src/lib/Text/Mustache/Internal.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-| -Module : $Header$ -Description : Types and conversions -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX - -escapeXML and xmlEntities curtesy to the tagsoup library. --} -{-# LANGUAGE UnicodeSyntax #-} -module Text.Mustache.Internal (uncons, escapeXMLText) where - - -import Data.Char (ord) -import qualified Data.IntMap as IntMap -import qualified Data.Text as T -import Prelude.Unicode - - -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", "\"") - , ("amp" , "&") - , ("lt" , "<") - , ("gt" , ">") - ] diff --git a/src/lib/Text/Mustache/Parser.hs b/src/lib/Text/Mustache/Parser.hs deleted file mode 100644 --- a/src/lib/Text/Mustache/Parser.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-| -Module : $Header$ -Description : Basic functions for dealing with mustache templates. -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UnicodeSyntax #-} -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 Control.Monad.Unicode -import Data.Char (isAlphaNum, isSpace) -import Data.Functor ((<$>)) -import Data.List (nub) -import Data.Monoid.Unicode ((∅), (⊕)) -import Data.Text as T (Text, null, pack) -import Prelude as Prel -import Prelude.Unicode -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 ("", "") (∅) 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 = (∅) } - 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 (∅)) - , SectionEnd - <$> (try (char sectionEnd) ≫ genParseTagEnd (∅)) - , Tag ∘ Variable False - <$> (try (char unescape1) ≫ genParseTagEnd (∅)) - , 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 (∅) ≫= \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 (∅) - ] - where - parseDelimChange = do - (MustacheState { sDelimiters = ( _, end )}) ← getState - spaces - delim1 ← allowedDelimiterCharacter `manyTill` space - spaces - delim2 ← allowedDelimiterCharacter `manyTill` try (spaces ≫ string (delimiterChange : end)) - when (delim1 ≡ (∅) ∨ delim2 ≡ (∅)) - $ 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 (∅) <$> (spaces ≫ string nEnd)) - return $ pack one : others - spaces - (try (char implicitIterator) ≫ spaces ≫ string nEnd ≫ return Implicit) - <|> (NamedData <$> parseOne) diff --git a/src/lib/Text/Mustache/Render.hs b/src/lib/Text/Mustache/Render.hs deleted file mode 100644 --- a/src/lib/Text/Mustache/Render.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-| -Module : $Header$ -Description : Functions for rendering mustache templates. -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} -module Text.Mustache.Render - ( - -- * Substitution - substitute, substituteValue - -- * Working with Context - , Context(..), search, innerSearch - -- * Util - , toString - ) where - - -import Control.Applicative ((<$>), (<|>)) -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Unicode -import Data.Foldable (fold) -import Data.HashMap.Strict as HM hiding (map) -import Data.Maybe (fromMaybe) -import Data.Monoid.Unicode -import Data.Scientific (floatingOrInteger) -import Data.Text as T (Text, isSuffixOf, null, pack, - replace, stripSuffix) -import qualified Data.Vector as V -import Prelude hiding (length, lines, unlines) -import Prelude.Unicode -import Text.Mustache.Internal -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 κ ⇒ Template → κ → Text -substitute t = substituteValue t ∘ toMustache - - -{-| - Substitutes all mustache defined tokens (or tags) for values found in the - provided data structure. --} -substituteValue ∷ Template → Value → Text -substituteValue (Template { ast = cAst, partials = cPartials }) dataStruct = - joinSubstituted (substitute' (Context (∅) dataStruct)) cAst - where - joinSubstituted f = fold ∘ fmap f - - -- Main substitution function - substitute' ∷ Context Value → Node Text → Text - - -- subtituting text - substitute' _ (TextBlock t) = t - - -- substituting a whole section (entails a focus shift) - substitute' (Context parents focus@(Array a)) (Section Implicit secSTree) - | V.null a = (∅) - | otherwise = flip joinSubstituted a $ \focus' → - let - newContext = Context (focus:parents) focus' - in - joinSubstituted (substitute' newContext) secSTree - substitute' context@(Context _ (Object _)) (Section Implicit secSTree) = - joinSubstituted (substitute' context) secSTree - substitute' _ (Section Implicit _) = (∅) - substitute' context@(Context parents focus) (Section (NamedData secName) secSTree) = - case search context secName of - Just arr@(Array arrCont) → - if V.null arrCont - then (∅) - else flip joinSubstituted arrCont $ \focus' → - let - newContext = Context (arr:focus:parents) focus' - in - joinSubstituted (substitute' newContext) secSTree - Just (Bool False) → (∅) - Just (Lambda l) → joinSubstituted (substitute' context) (l context secSTree) - Just focus' → - let - newContext = Context (focus:parents) focus' - in - joinSubstituted (substitute' newContext) secSTree - Nothing → (∅) - - -- substituting an inverted section - substitute' _ (InvertedSection Implicit _ ) = (∅) - substitute' context (InvertedSection (NamedData secName) invSecSTree) = - case search context secName of - Just (Bool False) → contents - Just (Array a) | V.null a → contents - Nothing → contents - _ → (∅) - where - contents = joinSubstituted (substitute' context) invSecSTree - - -- substituting a variable - substitute' (Context _ current) (Variable _ Implicit) = toString current - substitute' context (Variable escaped (NamedData varName)) = - maybe - (∅) - (if escaped then escapeXMLText else id) - $ toString <$> search context varName - - -- substituting a partial - substitute' context (Partial indent pName) = - maybe - (∅) - (joinSubstituted (substitute' context) ∘ handleIndent indent ∘ ast) - $ HM.lookup pName cPartials - - -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 - let - 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 - in - reverse $ fromMaybe [] (uncurry (:) ∘ first dropper <$> uncons (reverse fullIndented)) - - --- | 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 ∷ Context Value → [Key] → Maybe Value -search _ [] = Nothing -search ctx keys@(_:nextKeys) = go ctx keys ≫= innerSearch nextKeys - where - go _ [] = Nothing - go (Context parents focus) val@(x:_) = - ( case focus of - (Object o) → HM.lookup x o - _ → Nothing - ) - <|> ( do - (newFocus, newParents) ← uncons parents - go (Context newParents newFocus) val - ) - -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 - - --- | 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 - - --- | Converts values to Text as required by the mustache standard -toString ∷ Value → Text -toString (String t) = t -toString (Number n) = either (pack ∘ show) (pack ∘ show) (floatingOrInteger n ∷ Either Double Integer) -toString e = pack $ show e diff --git a/src/lib/Text/Mustache/Types.hs b/src/lib/Text/Mustache/Types.hs deleted file mode 100644 --- a/src/lib/Text/Mustache/Types.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-| -Module : $Header$ -Description : Types and conversions -Copyright : (c) Justus Adam, 2015 -License : LGPL-3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UnicodeSyntax #-} -module Text.Mustache.Types - ( - -- * Types for the Parser / Template - STree - , Template(..) - , Node(..) - , DataIdentifier(..) - -- * Types for the Substitution / Data - , Value(..) - , Key - -- ** Converting - , object - , (~>), (↝), (~=), (⥱) - , ToMustache, toMustache, mFromJSON - -- ** Representation - , Array, Object, Pair - , Context(..) - , TemplateCache - ) where - - -import qualified Data.Aeson as Aeson -import Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Map as Map -import Data.Scientific -import Data.Text -import qualified Data.Text.Lazy as LT -import qualified Data.Vector as V -import Prelude.Unicode - --- | Syntax tree for a mustache template -type STree = [Node Text] - - --- | Basic values composing the STree -data Node α - = TextBlock α - | Section DataIdentifier STree - | InvertedSection DataIdentifier STree - | 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 [α] α - deriving (Eq, Show, Ord) - --- | Internal value representation -data Value - = Object Object - | Array Array - | Number Scientific - | String Text - | Lambda (Context Value → STree → 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" - --- | Conversion class -class ToMustache ω where - toMustache ∷ ω → Value - listToMustache ∷ [ω] → Value - listToMustache = Array ∘ V.fromList ∘ fmap toMustache - -instance ToMustache Float where - toMustache = Number ∘ fromFloatDigits - -instance ToMustache Double where - toMustache = Number ∘ fromFloatDigits - -instance ToMustache Integer where - toMustache = Number ∘ fromInteger - -instance ToMustache Int where - toMustache = toMustache . toInteger - -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 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 (V.Vector ω) where - toMustache = toMustache ∘ 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 = toMustache ∘ 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 (Context Value → STree → STree) where - toMustache = Lambda - -instance ToMustache (Context Value → STree → Text) where - toMustache = lambdaInstanceHelper id - -instance ToMustache (Context Value → STree → LT.Text) where - toMustache = lambdaInstanceHelper LT.toStrict - -instance ToMustache (Context Value → STree → String) where - toMustache = lambdaInstanceHelper pack - -lambdaInstanceHelper :: (a -> Text) -> (Context Value -> STree -> a) -> Value -lambdaInstanceHelper conv f = Lambda wrapper - where - wrapper ∷ Context Value → STree → STree - wrapper c lSTree = return ∘ TextBlock $ conv $ f c lSTree - -instance ToMustache (STree → STree) where - toMustache f = toMustache (const f ∷ Context Value → STree → STree) - -instance ToMustache (STree → Text) where - toMustache f = toMustache wrapper - where - wrapper ∷ Context Value → STree → STree - wrapper _ = (return ∘ TextBlock) ∘ f - -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 = toMustache ∘ HS.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 - ] - --- | 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 - - --- | 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)