doctemplates 0.3.0.1 → 0.4

raw patch · 12 files changed

+719/−362 lines, 12 filesdep +criteriondep +doclayoutdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, doclayout

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +9/−3
• bench/bench.hs +32/−0
• changelog.md +47/−0
• doctemplates.cabal +20/−1
• src/Text/DocTemplates.hs +40/−352
• src/Text/DocTemplates/Internal.hs +251/−0
• src/Text/DocTemplates/Parser.hs +259/−0
• test/final-newline.test +15/−0
• test/indent.test +14/−2
• test/space-in-loop.test +27/−0
• test/test.hs +4/−3

@@ -1,4 +1,4 @@-Copyright John MacFarlane (c) 2016+Copyright John MacFarlane (c) 2009-2019  All rights reserved. 

@@ -1,7 +1,7 @@ # doctemplates  This is the templating system used by pandoc.  It was formerly-be a module in pandoc. It has been split off to make it easier+a module in pandoc. It has been split off to make it easier to use independently.  ## Example of use@@ -93,8 +93,9 @@   if true, and as the empty string if false. - Every other value will be rendered as the empty string. -The value of a variable will be indented to the same level as the-opening delimiter of the variable.+The value of a variable that occurs by itself on a line+will be indented to the same level as the opening delimiter of+the variable.  ## Conditionals @@ -217,6 +218,11 @@ ${ it:bibentry() } ${ endfor } ```++Note that the anaphoric keyword `it` must be used when+iterating over partials.  In the above examples,+the `bibentry` partial should contain `it.title`+(and so on) instead of `articles.title`.  Final newlines are omitted from included partials. 

@@ -0,0 +1,32 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+import Text.DocTemplates+import Data.Text (Text)+import Criterion.Main+import Criterion.Types (Config (..))+import Control.Monad.Identity+import Data.Aeson (object, (.=), Value)++main :: IO ()+main = do+  Right bigtextTemplate <- compileTemplate "bigtext.txt" bigtext+  defaultMainWith defaultConfig{ timeLimit = 5.0 } $+   [ bench "applyTemplate" $+      nf (runIdentity . applyTemplate "bigtext" bigtext+          :: Value -> Either String Text)+        val+   , bench "renderTemplate" $+      nf (renderTemplate bigtextTemplate :: Value -> Text)+        val+   ]++bigtext :: Text+bigtext = "Hello there $foo$. This is a big text.\n$for(bar)$$bar.baz$$endfor$"++val :: Value+val = object [ "foo" .= (22 :: Int)+             , "bar" .= [ object [ "baz" .= ("Hello"::Text) ]+                        , object [ "baz" .= ("Bye"::Text) ]+                        ]+             ]+

@@ -1,5 +1,52 @@ # doctemplates +## 0.4++  * Split into three modules.  Main module only exports an+    opaque version of the Template type.  Import Internal if you+    need to manipulate a Template.++  * Add Context type, parameterized on the underlying content's type.++  * Add Val type.++  * Add valueToContext for converting an Aeson Value to a Context.++  * Make renderTemplate and applyTemplate polymorphic in both+    context and target.  Context parameter is now any instance+    of ToContext (instead of ToJSON).  Result is now any+    instance of TemplateTarget.++  * Change type of getPartial in TemplateMonad so it runs in the+    TemplateMonad instance, not the Parser.  Return a simple+    value rather than an Either; error handling can vary with+    the monad.++  * Remove TemplatePart. Template is now an algebraci data type,+    not a list of TemplateParts.++  * Add an Indented type to indicate indentation for+    interpolated variables.++  * Improve architecture, doing more at compile time.++  * Depend on doclayout.  Context can be parameterized on a doclayout+    Doc type, allowing intelligent reflowing of content.++  * Remove single final newline in interpolated variable.++  * Remove final newline from partial.++  * Don't iterate when the variable evaluates to NullVal.++  * Only indented interpolated variables if by themselves on line.++  * Add Indented parameter to Interpolate constructor.++  * Update documentation and haddocks.++  * Add benchmark.+ ## 0.3.0.1  * Bump lower bound on base to 4.9, drop support for ghc 7.10.

@@ -1,5 +1,5 @@ name:                doctemplates-version:             0.3.0.1+version:             0.4 synopsis:            Pandoc-style document templates description:         A simple text templating system used by pandoc. homepage:            https://github.com/jgm/doctemplates#readme@@ -21,9 +21,12 @@ library   hs-source-dirs:      src   exposed-modules:     Text.DocTemplates+                       Text.DocTemplates.Parser+                       Text.DocTemplates.Internal   build-depends:       base >= 4.9 && < 5,                        aeson,                        text,+                       doclayout >= 0.1 && < 0.2,                        containers,                        vector,                        filepath,@@ -54,6 +57,22 @@                        text   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010++benchmark doctemplates-bench+  Type:            exitcode-stdio-1.0+  Main-Is:         bench.hs+  Hs-Source-Dirs:  bench+  Build-Depends:   doctemplates,+                   base >= 4.8 && < 5,+                   criterion >= 1.0 && < 1.6,+                   filepath,+                   aeson,+                   text,+                   containers,+                   mtl+  Ghc-Options:   -rtsopts -Wall -fno-warn-unused-do-bind+  Default-Language: Haskell2010+  source-repository head   type:     git

@@ -1,23 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {- |-   Module      : Text.Pandoc.Templates-   Copyright   : Copyright (C) 2009-2016 John MacFarlane+   Module      : Text.DocTemplates+   Copyright   : Copyright (C) 2009-2019 John MacFarlane    License     : BSD3     Maintainer  : John MacFarlane <jgm@berkeley.edu>    Stability   : alpha    Portability : portable -This is the templating system used by pandoc. It was formerly be a-module in pandoc. It has been split off to make it easier to use-independently.+The text templating system used by pandoc.  == Example of use @@ -101,8 +91,9 @@     true, and as the empty string if false. -   Every other value will be rendered as the empty string. -The value of a variable will be indented to the same level as the-opening delimiter of the variable.+The value of a variable that occurs by itself on a line+will be indented to the same level as the opening delimiter of+the variable.  == Conditionals @@ -206,6 +197,11 @@ > ${ it:bibentry() } > ${ endfor } +Note that the anaphoric keyword @it@ must be used when+iterating over partials.  In the above examples,+the @bibentry@ partial should contain @it.title@+(and so on) instead of @articles.title@.+ Final newlines are omitted from included partials.  Partials may include other partials. If you exceed a nesting level of@@ -227,350 +223,42 @@  module Text.DocTemplates ( renderTemplate                          , compileTemplate+                         , compileTemplateFile                          , applyTemplate                          , TemplateMonad(..)-                         , Template(..)-                         , TemplatePart(..)-                         , Variable(..)+                         , TemplateTarget(..)+                         , Context(..)+                         , Val(..)+                         , ToContext(..)+                         , FromContext(..)+                         , Template  -- export opaque type                          ) where -import Data.Char (isAlphaNum)-import Control.Monad (guard, when)-import Data.Aeson (Value(..), ToJSON(..))-import qualified Text.Parsec as P-import qualified Text.Parsec.Pos as P-import Control.Monad.Except-import Control.Exception-import System.IO.Error (isDoesNotExistError)-import Control.Monad.State-import Control.Monad.Identity-import Control.Applicative-import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Data.Data (Data)-import Data.Typeable (Typeable)-import GHC.Generics (Generic) import Data.Text (Text)-import Data.List (intersperse)-import qualified Data.HashMap.Strict as H-import Data.Foldable (toList)-import qualified Data.Vector as V-import Data.Scientific (floatingOrInteger)-import Data.Semigroup (Semigroup, (<>))-import System.FilePath--newtype Template = Template { unTemplate :: [TemplatePart] }-     deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)--#if MIN_VERSION_base(4,11,0)-instance Semigroup Template where-  Template xs <> Template ys = Template (xs <> ys)--instance Monoid Template where-  mempty = Template []-#else-instance Monoid Template where-  mappend (Template xs) (Template ys) = Template (mappend xs ys)-  mempty = Template []-#endif--data TemplatePart =-       Interpolate Variable-     | Conditional Variable Template Template-     | Iterate Variable Template Template-     | Partial Template-     | Literal Text-     deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)--newtype Variable = Variable { unVariable :: [Text] }-  deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)--#if MIN_VERSION_base(4,11,0)-instance Semigroup Variable where-  Variable xs <> Variable ys = Variable (xs <> ys)--instance Monoid Variable where-  mempty = Variable []-#else-instance Monoid Variable where-  mappend (Variable xs) (Variable ys) = Variable (mappend xs ys)-  mempty = Variable []-#endif--renderTemplate :: ToJSON a => Template -> a -> Text-renderTemplate t context = evalState (renderer t (toJSON context)) 0--it :: Variable-it = Variable ["it"]--renderer :: Template -> Value -> State Int Text-renderer (Template xs) val = mconcat <$> mapM renderPart xs-  where-   modifyIndent t = do-     ind <- get-     put $ T.foldl' (\cur c ->-                 case c of-                   '\n' -> 0-                   _    -> cur + 1) ind t-   renderPart x =-     case x of-       Literal t -> do-         modifyIndent t-         return t-       Interpolate v -> do-         ind <- get-         let t = indent ind $ resolveVar v val-         modifyIndent t-         return t-       Conditional v ift elset -> renderer branch val-         where branch = case resolveVar v val of-                          "" -> elset-                          _  -> ift-       Iterate v t sep ->-         case multiLookup (unVariable v) val of-           Just (Array vec) -> do-             sep' <- renderer sep val-             iters <- mapM (\iterval -> renderer t .-                                replaceVar v iterval .-                                replaceVar it iterval $-                                val) (toList vec)-             return $ mconcat $ intersperse sep' iters-           Just val' -> renderer t $ replaceVar it val' val-           Nothing -> return mempty-       Partial t -> renderer t val--class Monad m => TemplateMonad m where-  getPartial  :: FilePath -> Parser m Text+import Text.DocTemplates.Parser (compileTemplate)+import Text.DocTemplates.Internal ( TemplateMonad(..), Context(..),+            Val(..), ToContext(..), FromContext(..), TemplateTarget(..), Template,+            renderTemplate ) -instance TemplateMonad Identity where-  getPartial s  = fail $ "Could not get partial: " <> s+-- | Compile a template from a file.  IO errors will be+-- raised as exceptions; template parsing errors result in+-- Left return values.+compileTemplateFile :: FilePath -> IO (Either String Template)+compileTemplateFile templPath = do+  templateText <- TIO.readFile templPath+  compileTemplate templPath templateText -instance TemplateMonad IO where-  getPartial s  = do-    res <- liftIO $ tryJust (guard . isDoesNotExistError)-              (TIO.readFile s)+-- | Compile a template and apply it to a context.  This is+-- just a convenience function composing 'compileTemplate'+-- and 'renderTemplate'.  If a template will be rendered+-- more than once in the same process, compile it separately+-- for better performance.+applyTemplate :: (TemplateMonad m, TemplateTarget a, ToContext b a)+           => FilePath -> Text -> b -> m (Either String a)+applyTemplate fp t val = do+    res <- compileTemplate fp t     case res of-      Left _  -> fail $ "Could not get partial " ++ s-      Right x -> return x--compileTemplate :: TemplateMonad m-                => FilePath -> Text -> m (Either String Template)-compileTemplate templPath template = do-  res <- P.runParserT (pTemplate <* P.eof)-           PState{ templatePath   = templPath-                 , partialNesting = 1 } "template" template-  case res of-       Left e   -> return $ Left $ show e-       Right x  -> return $ Right x--applyTemplate :: (TemplateMonad m, ToJSON a)-              => FilePath -> Text -> a -> m (Either String Text)-applyTemplate fp t val =-  fmap (`renderTemplate` val) <$> compileTemplate fp t--data PState =-  PState { templatePath   :: FilePath-         , partialNesting :: Int }--type Parser = P.ParsecT Text PState--pTemplate :: TemplateMonad m => Parser m Template-pTemplate = do-  ts <- many $ P.try-         (P.skipMany pComment *> (pLit <|> pDirective <|> pEscape))-  P.skipMany pComment-  return $ Template ts--pLit :: Monad m => Parser m TemplatePart-pLit = Literal . mconcat <$>-  P.many1 (T.pack <$> P.many1 (P.satisfy (/= '$')))--backupSourcePos :: Monad m => Int -> Parser m ()-backupSourcePos n = do-  pos <- P.getPosition-  P.setPosition $ P.incSourceColumn pos (- n)--pEscape :: Monad m => Parser m TemplatePart-pEscape = Literal "$" <$ P.try (P.string "$$" <* backupSourcePos 1)--pDirective :: TemplateMonad m => Parser m TemplatePart-pDirective = pConditional <|> pForLoop <|> pInterpolate <|> pBarePartial--pEnclosed :: Monad m => Parser m a -> Parser m a-pEnclosed parser = P.try $ do-  closer <- pOpen-  P.skipMany pSpaceOrTab-  result <- parser-  P.skipMany pSpaceOrTab-  closer-  return result--pParens :: Monad m => Parser m a -> Parser m a-pParens parser = do-  P.char '('-  result <- parser-  P.char ')'-  return result--pConditional :: TemplateMonad m => Parser m TemplatePart-pConditional = do-  v <- pEnclosed $ P.try $ P.string "if" *> pParens pVar-  -- if newline after the "if", then a newline after "endif" will be swallowed-  multiline <- P.option False (True <$ skipEndline)-  ifContents <- pTemplate-  elseContents <- P.option mempty $-                    do pEnclosed (P.string "else")-                       when multiline $ P.option () skipEndline-                       pTemplate-  pEnclosed (P.string "endif")-  when multiline $ P.option () skipEndline-  return $ Conditional v ifContents elseContents--skipEndline :: Monad m => Parser m ()-skipEndline = P.try $ P.skipMany pSpaceOrTab <* P.char '\n'--pForLoop :: TemplateMonad m => Parser m TemplatePart-pForLoop = do-  v <- pEnclosed $ P.try $ P.string "for" *> pParens pVar-  -- if newline after the "for", then a newline after "endfor" will be swallowed-  multiline <- P.option False $ skipEndline >> return True-  contents <- pTemplate-  sep <- P.option mempty $-           do pEnclosed (P.string "sep")-              when multiline $ P.option () skipEndline-              pTemplate-  pEnclosed (P.string "endfor")-  when multiline $ P.option () skipEndline-  return $ Iterate v contents sep--pInterpolate :: TemplateMonad m => Parser m TemplatePart-pInterpolate = pEnclosed $ do-  var <- pVar-  (P.char ':' *> pPartial (Just var))-    <|> do separ <- pSep-           return (Iterate var (Template [Interpolate it])-                    separ)-    <|> return (Interpolate var)--pBarePartial :: TemplateMonad m => Parser m TemplatePart-pBarePartial = pEnclosed $ pPartial Nothing--pPartial :: TemplateMonad m => Maybe Variable -> Parser m TemplatePart-pPartial mbvar = do-  fp <- P.many1 (P.alphaNum <|> P.oneOf ['_','-','.','/','\\'])-  P.string "()"-  separ <- P.option mempty pSep-  tp <- templatePath <$> P.getState-  let fp' = case takeExtension fp of-               "" -> replaceBaseName tp fp-               _  -> replaceFileName tp fp-  partial <- removeFinalNewline <$> getPartial fp'-  nesting <- partialNesting <$> P.getState-  t <- if nesting > 50-          then return $ Template [Literal "(loop)"]-          else do-            oldInput <- P.getInput-            oldPos <- P.getPosition-            P.setPosition $ P.initialPos fp-            P.setInput partial-            P.updateState $ \st -> st{ partialNesting = nesting + 1 }-            res <- pTemplate <* P.eof-            P.updateState $ \st -> st{ partialNesting = nesting }-            P.setInput oldInput-            P.setPosition oldPos-            return res-  case mbvar of-    Just var -> return $ Iterate var t separ-    Nothing  -> return $ Partial t--pSep :: Monad m => Parser m Template-pSep = do-    P.char '['-    xs <- P.many (P.satisfy (/= ']'))-    P.char ']'-    return $ Template [Literal (T.pack xs)]--removeFinalNewline :: Text -> Text-removeFinalNewline t =-  case T.unsnoc t of-    Just (t', '\n') -> t'-    _               -> t--pSpaceOrTab :: Monad m => Parser m Char-pSpaceOrTab = P.satisfy (\c -> c == ' ' || c == '\t')--pComment :: Monad m => Parser m ()-pComment = do-  pos <- P.getPosition-  P.try (P.string "$--")-  P.skipMany (P.satisfy (/='\n'))-  -- If the comment begins in the first column, the line ending-  -- will be consumed; otherwise not.-  when (P.sourceColumn pos == 1) $ () <$ P.char '\n'--pOpenDollar :: Monad m => Parser m (Parser m ())-pOpenDollar =-  pCloseDollar <$ P.try (P.char '$' <*-                   P.notFollowedBy (P.char '$' <|> P.char '{'))-  where-   pCloseDollar = () <$ P.char '$'--pOpenBraces :: Monad m => Parser m (Parser m ())-pOpenBraces =-  pCloseBraces <$ P.try (P.string "${" <* P.notFollowedBy (P.char '}'))-  where-   pCloseBraces = () <$ P.try (P.char '}')--pOpen :: Monad m => Parser m (Parser m ())-pOpen = pOpenDollar <|> pOpenBraces--pVar :: Monad m => Parser m Variable-pVar = do-  first <- pIdentPart <|> "it" <$ P.try (P.string "it")-  rest <- P.many $ P.char '.' *> pIdentPart-  return $ Variable (first:rest)--pIdentPart :: Monad m => Parser m Text-pIdentPart = P.try $ do-  first <- P.letter-  rest <- T.pack <$>-            P.many (P.satisfy (\c -> isAlphaNum c || c == '_' || c == '-'))-  let part = T.singleton first <> rest-  guard $ part `notElem` reservedWords-  return part--reservedWords :: [Text]-reservedWords = ["else","endif","for","endfor","sep","it"]--resolveVar :: Variable -> Value -> Text-resolveVar (Variable var') val =-  case multiLookup var' val of-       Just (Array vec) -> mconcat $ map (resolveVar mempty) $ V.toList vec-       Just (String t)  -> T.stripEnd t-       Just (Number n)  -> case floatingOrInteger n of-                                   Left (r :: Double)   -> T.pack $ show r-                                   Right (i :: Integer) -> T.pack $ show i-       Just (Bool True) -> "true"-       Just (Object _)  -> "true"-       Just _           -> mempty-       Nothing          -> mempty--multiLookup :: [Text] -> Value -> Maybe Value-multiLookup [] x = Just x-multiLookup (v:vs) (Object o) = H.lookup v o >>= multiLookup vs-multiLookup _ _ = Nothing--replaceVar :: Variable -- ^ Field-           -> Value -- ^ New value-           -> Value -- ^ Old object-           -> Value -- ^ New object-replaceVar (Variable [])     new _          = new-replaceVar (Variable (v:vs)) new (Object o) = Object $ H.alter f v o-    where f Nothing  = Just new-          f (Just x) = Just (replaceVar (Variable vs) new x)-replaceVar _ _ old = old--indent :: Int -> Text -> Text-indent 0   = id-indent ind = T.intercalate ("\n" <> T.replicate ind " ") . T.lines+      Left   s  -> return $ Left s+      Right  t' -> return $ Right $ renderTemplate t' val 

@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}++{- |+   Module      : Text.DocTemplates.Internal+   Copyright   : Copyright (C) 2009-2019 John MacFarlane+   License     : BSD3++   Maintainer  : John MacFarlane <jgm@berkeley.edu>+   Stability   : alpha+   Portability : portable+-}++module Text.DocTemplates.Internal+      ( renderTemplate+      , TemplateMonad(..)+      , Context(..)+      , Val(..)+      , ToContext(..)+      , FromContext(..)+      , valueToContext+      , TemplateTarget(..)+      , Template(..)+      , Variable(..)+      , Indented(..)+      ) where++import Data.Aeson (Value(..), ToJSON(..))+import Control.Monad.Identity+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Text.DocLayout as DL+import Data.String (IsString(..))+import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Data.Text (Text)+import qualified Data.Map as M+import qualified Data.HashMap.Strict as H+import qualified Data.Vector as V+import Data.Scientific (floatingOrInteger)+import Data.List (intersperse)+#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup+#endif++-- | Determines whether an interpolated variable is rendered with+-- indentation.+data Indented = Indented !Int | Unindented+     deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)++-- | A template.+data Template =+       Interpolate Indented Variable+     | Conditional Variable Template Template+     | Iterate Variable Template Template+     | Partial Template+     | Literal Text+     | Concat Template Template+     | Empty+     deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)++instance Semigroup Template where+  x <> Empty = x+  Empty <> x = x+  x <> y = Concat x y++instance Monoid Template where+  mappend = (<>)+  mempty = Empty++-- | A variable which may have several parts (@foo.bar.baz@).+newtype Variable = Variable { unVariable :: [Text] }+  deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)++instance Semigroup Variable where+  Variable xs <> Variable ys = Variable (xs <> ys)++instance Monoid Variable where+  mempty = Variable []+  mappend = (<>)++-- | A type to which templates can be rendered.+class Monoid a => TemplateTarget a where+  fromText           :: Text -> a+  removeFinalNewline :: a -> a+  isEmpty            :: a -> Bool+  indent             :: Int -> a -> a++instance TemplateTarget Text where+  fromText   = id+  removeFinalNewline t =+    case T.unsnoc t of+      Just (t', '\n') -> t'+      _               -> t+  isEmpty    = T.null+  indent 0   = id+  indent ind = T.intercalate ("\n" <> T.replicate ind " ") . T.lines++instance IsString a => TemplateTarget (DL.Doc a) where+  fromText = DL.text . T.unpack+  removeFinalNewline = DL.chomp+  indent = DL.nest+  isEmpty = DL.isEmpty+++-- | A 'Context' defines values for template's variables.+newtype Context a = Context { unContext :: M.Map Text (Val a) }+  deriving (Show, Semigroup, Monoid, Traversable, Foldable, Functor)++-- | A variable value.+data Val a =+    SimpleVal  a+  | ListVal    [Val a]+  | MapVal     (Context a)+  | NullVal+  deriving (Show, Traversable, Foldable, Functor)++-- | The 'ToContext' class provides automatic conversion to+-- a 'Context'.+class ToContext b a where+  toContext :: b -> Context a++instance TemplateTarget a => ToContext Value a where+  toContext = valueToContext++instance ToContext (Context a) a where+  toContext = id++-- | The 'FromContext' class provides functions for extracting+-- values from 'Val' and 'Context'.+class FromContext a b where+  fromVal :: Val a -> Maybe b+  lookupContext :: Text -> Context a -> Maybe b+  lookupContext t (Context m) = M.lookup t m >>= fromVal++instance FromContext a (Val a) where+  fromVal = Just++instance FromContext a a where+  fromVal (SimpleVal x) = Just x+  fromVal _             = Nothing++instance FromContext a [a] where+  fromVal (SimpleVal x) = Just [x]+  fromVal (ListVal  xs) = mapM fromVal xs+  fromVal _             = Nothing++valueToVal :: (TemplateTarget a, ToJSON b) => b -> Val a+valueToVal x =+  case toJSON x of+    Array vec   -> ListVal $ map valueToVal $ V.toList vec+    String t    -> SimpleVal $ fromText t+    Number n    -> SimpleVal $ fromText . fromString $+                           case floatingOrInteger n of+                                Left (r :: Double)   -> show r+                                Right (i :: Integer) -> show i+    Bool True   -> SimpleVal $ fromText "true"+    Object o    -> MapVal $ Context $ M.fromList $ H.toList $ H.map valueToVal o+    _           -> NullVal++-- | Converts an Aeson 'Value' to a 'Context'.+valueToContext :: (TemplateTarget a, ToJSON b) => b -> Context a+valueToContext val =+  case valueToVal val of+    MapVal o -> o+    _        -> Context mempty+++multiLookup :: [Text] -> Val a -> Val a+multiLookup [] x = x+multiLookup (v:vs) (MapVal (Context o)) =+  case M.lookup v o of+    Nothing -> NullVal+    Just v' -> multiLookup vs v'+multiLookup _ _ = NullVal++resolveVariable :: TemplateTarget a => Variable -> Context a -> [a]+resolveVariable v ctx = resolveVariable' v (MapVal ctx)++resolveVariable' :: TemplateTarget a => Variable -> Val a -> [a]+resolveVariable' v val =+  case multiLookup (unVariable v) val of+    ListVal xs    -> concatMap (resolveVariable' mempty) xs+    SimpleVal t+      | isEmpty t -> []+      | otherwise -> [removeFinalNewline t]+    MapVal _      -> [fromText "true"]+    NullVal       -> []++withVariable :: TemplateTarget a+             => Variable -> Context a -> (Context a -> a) -> [a]+withVariable  v ctx f =+  case multiLookup (unVariable v) (MapVal ctx) of+    NullVal     -> mempty+    ListVal xs  -> map (\iterval -> f $+                    Context $ M.insert "it" iterval $ unContext ctx) xs+    val' -> [f $ Context $ M.insert "it" val' $ unContext ctx]++-- | Render a compiled template in a "context" which provides+-- values for the template's variables.+renderTemplate :: (TemplateTarget a, ToContext b a)+               => Template -> b -> a+renderTemplate t = renderTemp t . toContext++renderTemp :: forall a . TemplateTarget a+           => Template -> Context a -> a+renderTemp (Literal t) _ = fromText t+renderTemp (Interpolate indented v) ctx =+  let vals = resolveVariable v ctx+   in if null vals+         then mempty+         else case indented of+                Indented ind -> indent ind $ mconcat vals+                _            -> mconcat vals+renderTemp (Conditional v ift elset) ctx =+  let res = resolveVariable v ctx+   in case res of+        [] -> renderTemp elset ctx+        _  -> renderTemp ift ctx+renderTemp (Iterate v t sep) ctx =+  let sep' = renderTemp sep ctx+   in mconcat . intersperse sep' $ withVariable v ctx (renderTemp t)+renderTemp (Partial t) ctx = renderTemp t ctx+renderTemp (Concat t1 t2) ctx =+  mappend (renderTemp t1 ctx) (renderTemp t2 ctx)+renderTemp Empty _ = mempty++-- | A 'TemplateMonad' defines a function to retrieve a partial+-- (from the file system, from a database, or using a default+-- value).+class Monad m => TemplateMonad m where+  getPartial  :: FilePath -> m Text++instance TemplateMonad Identity where+  getPartial _  = return mempty++instance TemplateMonad IO where+  getPartial = TIO.readFile

@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{- |+   Module      : Text.DocTemplates.Parser+   Copyright   : Copyright (C) 2009-2019 John MacFarlane+   License     : BSD3++   Maintainer  : John MacFarlane <jgm@berkeley.edu>+   Stability   : alpha+   Portability : portable+-}++module Text.DocTemplates.Parser+    ( compileTemplate ) where++import Data.Char (isAlphaNum)+import Control.Monad (guard, when)+import Control.Monad.Trans (lift)+import qualified Text.Parsec as P+import qualified Text.Parsec.Pos as P+import Control.Applicative+import Data.String (IsString(..))+import Data.Text (Text)+import Data.List (isPrefixOf)+import System.FilePath+import Text.DocTemplates.Internal+#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup ((<>))+#endif++-- | Compile a template.  The FilePath parameter is used+-- to determine a default path and extension for partials+-- and may be left empty if partials are not used.+compileTemplate :: TemplateMonad m+                => FilePath -> Text -> m (Either String Template)+compileTemplate templPath template = do+  res <- P.runParserT (pTemplate <* P.eof)+           PState{ templatePath   = templPath+                 , partialNesting = 1+                 , beginsLine = True } "template" template+  case res of+       Left e   -> return $ Left $ show e+       Right x  -> return $ Right x+++data PState =+  PState { templatePath   :: FilePath+         , partialNesting :: Int+         , beginsLine     :: Bool }++type Parser = P.ParsecT Text PState++pTemplate :: TemplateMonad m => Parser m Template+pTemplate = do+  ts <- many $ P.try+         (P.skipMany pComment *> (pLit <|> pDirective <|> pEscape))+  P.skipMany pComment+  return $ mconcat ts++pLit :: Monad m => Parser m Template+pLit = do+  cs <- mconcat <$> P.many1 (P.many1 (P.satisfy (/= '$')))+  P.updateState $ \st ->+    st{ beginsLine =+          case dropWhile (\c -> c == ' ' || c == '\t') $ reverse cs of+            ('\n':_) -> True+            []       -> beginsLine st+            _        -> False }+  return $ Literal $ fromString cs++backupSourcePos :: Monad m => Int -> Parser m ()+backupSourcePos n = do+  pos <- P.getPosition+  P.setPosition $ P.incSourceColumn pos (- n)++pEscape :: Monad m => Parser m Template+pEscape = Literal "$" <$ P.try (P.string "$$" <* backupSourcePos 1)++pDirective :: TemplateMonad m+           => Parser m Template+pDirective = do+  res <- pConditional <|> pForLoop <|> pInterpolate <|> pBarePartial+  col <- P.sourceColumn <$> P.getPosition+  P.updateState $ \st -> st{ beginsLine = col == 1 }+  return res++pEnclosed :: Monad m => Parser m a -> Parser m a+pEnclosed parser = P.try $ do+  closer <- pOpen+  P.skipMany pSpaceOrTab+  result <- parser+  P.skipMany pSpaceOrTab+  closer+  return result++pParens :: Monad m => Parser m a -> Parser m a+pParens parser = do+  P.char '('+  result <- parser+  P.char ')'+  return result++pConditional :: TemplateMonad m+             => Parser m Template+pConditional = do+  v <- pEnclosed $ P.try $ P.string "if" *> pParens pVar+  -- if newline after the "if", then a newline after "endif" will be swallowed+  multiline <- P.option False (True <$ skipEndline)+  ifContents <- pTemplate+  elseContents <- P.option mempty $+                    do pEnclosed (P.string "else")+                       when multiline $ P.option () skipEndline+                       pTemplate+  pEnclosed (P.string "endif")+  when multiline $ P.option () skipEndline+  return $ Conditional v ifContents elseContents++skipEndline :: Monad m => Parser m ()+skipEndline = P.try $ P.skipMany pSpaceOrTab <* P.char '\n'++pForLoop :: TemplateMonad m+         => Parser m Template+pForLoop = do+  v <- pEnclosed $ P.try $ P.string "for" *> pParens pVar+  -- if newline after the "for", then a newline after "endfor" will be swallowed+  multiline <- P.option False $ skipEndline >> return True+  contents <- changeToIt v <$> pTemplate+  sep <- P.option mempty $+           do pEnclosed (P.string "sep")+              when multiline $ P.option () skipEndline+              changeToIt v <$> pTemplate+  pEnclosed (P.string "endfor")+  when multiline $ P.option () skipEndline+  return $ Iterate v contents sep++changeToIt :: Variable -> Template -> Template+changeToIt v = go+ where+  go (Interpolate i w) = Interpolate i (reletter v w)+  go (Conditional w t1 t2) = Conditional (reletter v w)+        (changeToIt v t1) (changeToIt v t2)+  go (Iterate w t1 t2) = Iterate (reletter v w)+        (changeToIt v t1) (changeToIt v t2)+  go (Partial t) = Partial t  -- don't reletter inside partial+  go (Literal x) = Literal x+  go (Concat t1 t2) = changeToIt v t1 <> changeToIt v t2+  go Empty = mempty+  reletter (Variable vs) (Variable ws) =+    if vs `isPrefixOf` ws+       then Variable ("it" : drop (length vs) ws)+       else Variable ws++pInterpolate :: TemplateMonad m+             => Parser m Template+pInterpolate = do+  begins <- beginsLine <$> P.getState+  pos <- P.getPosition+  res <- pEnclosed $ do+    var <- pVar+    (P.char ':' *> pPartial (Just var))+      <|> Iterate var (Interpolate Unindented (Variable ["it"])) <$> pSep+      <|> return (Interpolate Unindented var)+  ends <- P.lookAhead $ P.option False $+             True <$ P.try (P.skipMany pSpaceOrTab *> P.newline)+  case (begins && ends, res) of+    (True, Interpolate _ v)+               -> return $ Interpolate (Indented (P.sourceColumn pos - 1)) v+    (True, Iterate v (Interpolate _ v') s)+               -> return $ Iterate v+                    (Interpolate (Indented (P.sourceColumn pos - 1)) v') s+    _ -> return res++pBarePartial :: TemplateMonad m+             => Parser m Template+pBarePartial = pEnclosed $ pPartial Nothing++pPartial :: TemplateMonad m+         => Maybe Variable -> Parser m Template+pPartial mbvar = do+  fp <- P.many1 (P.alphaNum <|> P.oneOf ['_','-','.','/','\\'])+  P.string "()"+  separ <- P.option mempty pSep+  tp <- templatePath <$> P.getState+  let fp' = case takeExtension fp of+               "" -> replaceBaseName tp fp+               _  -> replaceFileName tp fp+  partial <- lift $ removeFinalNewline <$> getPartial fp'+  nesting <- partialNesting <$> P.getState+  t <- if nesting > 50+          then return $ Literal "(loop)"+          else do+            oldInput <- P.getInput+            oldPos <- P.getPosition+            P.setPosition $ P.initialPos fp+            P.setInput partial+            P.updateState $ \st -> st{ partialNesting = nesting + 1 }+            res' <- pTemplate <* P.eof+            P.updateState $ \st -> st{ partialNesting = nesting }+            P.setInput oldInput+            P.setPosition oldPos+            return res'+  case mbvar of+    Just var -> return $ Iterate var t separ+    Nothing  -> return $ Partial t++pSep :: Monad m => Parser m Template+pSep = do+    P.char '['+    xs <- P.many (P.satisfy (/= ']'))+    P.char ']'+    return $ Literal (fromString xs)++pSpaceOrTab :: Monad m => Parser m Char+pSpaceOrTab = P.satisfy (\c -> c == ' ' || c == '\t')++pComment :: Monad m => Parser m ()+pComment = do+  pos <- P.getPosition+  P.try (P.string "$--")+  P.skipMany (P.satisfy (/='\n'))+  -- If the comment begins in the first column, the line ending+  -- will be consumed; otherwise not.+  when (P.sourceColumn pos == 1) $ () <$ do+    P.char '\n'+    P.updateState $ \st -> st{ beginsLine = True }++pOpenDollar :: Monad m => Parser m (Parser m ())+pOpenDollar =+  pCloseDollar <$ P.try (P.char '$' <*+                   P.notFollowedBy (P.char '$' <|> P.char '{'))+  where+   pCloseDollar = () <$ P.char '$'++pOpenBraces :: Monad m => Parser m (Parser m ())+pOpenBraces =+  pCloseBraces <$ P.try (P.string "${" <* P.notFollowedBy (P.char '}'))+  where+   pCloseBraces = () <$ P.try (P.char '}')++pOpen :: Monad m => Parser m (Parser m ())+pOpen = pOpenDollar <|> pOpenBraces++pVar :: Monad m => Parser m Variable+pVar = do+  first <- pIdentPart <|> "it" <$ P.try (P.string "it")+  rest <- P.many $ P.char '.' *> pIdentPart+  return $ Variable (first:rest)++pIdentPart :: Monad m => Parser m Text+pIdentPart = P.try $ do+  first <- P.letter+  rest <- P.many (P.satisfy (\c -> isAlphaNum c || c == '_' || c == '-'))+  let part = first : rest+  guard $ part `notElem` reservedWords+  return $ fromString part++reservedWords :: [String]+reservedWords = ["else","endif","for","endfor","sep","it"]

@@ -0,0 +1,15 @@+{ "employee":+  [ { "name": "John\n" }+  , { "name": "Sara\n\n" }+  , { "name": "Omar" }+  ]+}+.+$for(employee)$+$employee.name$+$ endfor $+.+John+Sara++Omar

@@ -1,4 +1,4 @@-{ "foo": "FOO"+{ "foo": "FOO1\nFOO2" , "bar": [ "LINE1\n LINE2"          , "LINE3\n LINE4"          ]@@ -10,9 +10,21 @@ $for(bar)$   $bar$ $endfor$++- $foo$+  $foo$ -+  $if(foo)$$foo$$endif$ .-   FOO+   FOO1+   FOO2   LINE1    LINE2   LINE3    LINE4++- FOO1+FOO2+  FOO1+FOO2 -+  FOO1+FOO2

@@ -0,0 +1,27 @@+{ "employee":+  [ { "name": { "first": "John", "last": "Doe" } }+  , { "name": { "first": "Omar", "last": "Smith" }+    , "salary": "30000" }+  , { "name": { "first": "Sara", "last": "Chen" }+    , "salary": "60000" }+  ]+}+.+$for(employee)$+$employee.name.first$++$endfor$+---+$for(nonexistent)$++$endfor$+---+.+John++Omar++Sara++---+---

@@ -28,10 +28,11 @@ unitTests :: [TestTree] unitTests = [     testCase "compile failure" $ do-      res <- compileTemplate "" "$if(x$and$endif$"+      (res :: Either String Template)+        <- compileTemplate "" "$if(x$and$endif$"       res @?= Left "\"template\" (line 1, column 6):\nunexpected \"$\"\nexpecting \".\" or \")\""   , testCase "compile failure (keyword as variable)" $ do-      res <- compileTemplate "" "$sep$"+      (res :: Either String Template) <- compileTemplate "" "$sep$"       res @?= Left "\"template\" (line 1, column 5):\nunexpected \"$\"\nexpecting letter or digit or \"()\""   ] @@ -58,7 +59,7 @@     let template = template' <> "\n"     let templatePath = replaceExtension fp ".txt"     let Just (context :: Value) = decode' . BL.fromStrict . T.encodeUtf8 $ json-    res <- applyTemplate templatePath template (context :: Value)+    res <- applyTemplate templatePath template context     case res of       Left e -> error e       Right x -> T.writeFile actual $ json <> ".\n" <> template <> ".\n" <> x