ginger (empty) → 0.1.0.0
raw patch · 10 files changed
+1927/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, data-default, filepath, ginger, mtl, parsec, safe, scientific, text, transformers, unordered-containers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- cli/GingerCLI.hs +111/−0
- ginger.cabal +57/−0
- src/Text/Ginger.hs +239/−0
- src/Text/Ginger/AST.hs +61/−0
- src/Text/Ginger/GVal.hs +341/−0
- src/Text/Ginger/Html.hs +64/−0
- src/Text/Ginger/Parse.hs +633/−0
- src/Text/Ginger/Run.hs +399/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Tobias Dammers++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cli/GingerCLI.hs view
@@ -0,0 +1,111 @@+-- | An example Ginger CLI application.+--+-- Takes two optional arguments; the first one is a template file, the second+-- one a file containing some context data in JSON format.+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Main where++import Text.Ginger+import Text.Ginger.Html+import Data.Text as Text+import qualified Data.Aeson as JSON+import Data.Maybe+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Control.Applicative+import System.Environment ( getArgs )+import System.IO+import System.IO.Error+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Control.Monad.Trans.Class ( lift )+import Control.Monad.Trans.Maybe+import Control.Monad+import Data.Default ( def )++loadFile fn = openFile fn ReadMode >>= hGetContents++loadFileMay fn =+ tryIOError (loadFile fn) >>= \e ->+ case e of+ Right contents -> return (Just contents)+ Left err -> do+ print err+ return Nothing++decodeFile :: (JSON.FromJSON v) => FilePath -> IO (Maybe v)+decodeFile fn = JSON.decode <$> (openFile fn ReadMode >>= LBS.hGetContents)++printF :: GVal (Run IO)+printF = fromFunction $ go+ where+ go :: [(Maybe Text, GVal (Run IO))] -> Run IO (GVal (Run IO))+ go args = forM_ args printArg >> return def+ printArg (Nothing, v) = liftRun . putStrLn . Text.unpack . asText $ v+ printArg (Just x, _) = return ()++main = do+ args <- getArgs+ let (srcFn, scopeFn) = case args of+ [] -> (Nothing, Nothing)+ a:[] -> (Just a, Nothing)+ a:b:[] -> (Just a, Just b)++ scope <- case scopeFn of+ Nothing -> return Nothing+ Just fn -> (decodeFile fn :: IO (Maybe (HashMap Text JSON.Value)))++ let scopeLookup key = toGVal (scope >>= HashMap.lookup key)+ resolve = loadFileMay+ let contextLookup :: Text -> Run IO (GVal (Run IO))+ contextLookup key =+ case key of+ "print" -> return printF+ _ -> return $ scopeLookup key++ (tpl, src) <- case srcFn of+ Just fn -> (,) <$> parseGingerFile resolve fn <*> return Nothing+ Nothing -> getContents >>= \s -> (,) <$> parseGinger resolve Nothing s <*> return (Just s)++ -- TODO: do some sort of arg parsing thing so that we can turn+ -- template dumping on or off.+ -- print tpl++ case tpl of+ Left err -> do+ printParserError err+ tplSource <- case src of+ Just s -> return s+ Nothing -> do+ let s = peSourceName err+ case s of+ Nothing -> return ""+ Just sn -> loadFile sn+ displayParserError tplSource err+ Right t -> runGingerT (makeContextM contextLookup (putStr . Text.unpack . htmlSource)) t++printParserError :: ParserError -> IO ()+printParserError = putStrLn . formatParserError++formatParserError :: ParserError -> String+formatParserError pe = Prelude.concat+ [ fromMaybe "<<unknown source>>" . peSourceName $ pe+ , ":"+ , fromMaybe "" $ (++ ":") . show <$> peSourceLine pe+ , fromMaybe "" $ (++ ":") . show <$> peSourceColumn pe+ , peErrorMessage pe ]++displayParserError :: String -> ParserError -> IO ()+displayParserError src pe = do+ case (peSourceLine pe, peSourceColumn pe) of+ (Just l, cMay) -> do+ let ln = Prelude.take 1 . Prelude.drop (l - 1) . Prelude.lines $ src+ case ln of+ [] -> return ()+ x:_ -> do+ putStrLn x+ case cMay of+ Just c -> putStrLn $ Prelude.replicate (c - 1) ' ' ++ "^"+ _ -> return ()+ _ -> return ()
+ ginger.cabal view
@@ -0,0 +1,57 @@+-- Initial ginger.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: ginger+version: 0.1.0.0+synopsis: An implementation of the Jinja2 template language in Haskell+-- description: +homepage: https://bitbucket.org/tdammers/ginger+license: MIT+license-file: LICENSE+author: Tobias Dammers+maintainer: tdammers@gmail.com+-- copyright: +category: Text+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Text.Ginger+ , Text.Ginger.AST+ , Text.Ginger.GVal+ , Text.Ginger.Html+ , Text.Ginger.Parse+ , Text.Ginger.Run+ -- other-modules: + -- other-extensions: + build-depends: base >=4.5 && <5+ , aeson+ , bytestring+ , data-default >= 0.5+ , filepath >= 1.3+ , mtl >= 2.2+ , parsec >= 3.0+ , safe >= 0.3+ , scientific >= 0.3+ , text+ , transformers >= 0.3+ , unordered-containers >= 0.2.5+ , vector+ hs-source-dirs: src+ default-language: Haskell2010+ GHC-options: -O0++executable ginger+ main-is: GingerCLI.hs+ hs-source-dirs: cli+ default-language: Haskell2010+ build-depends: base >= 4.5 && <5+ , bytestring+ , data-default >= 0.5+ , ginger+ , aeson+ , text+ , transformers+ , unordered-containers >= 0.2.5+ GHC-options: -O0
+ src/Text/Ginger.hs view
@@ -0,0 +1,239 @@+{-|+A Haskell implementation of the <http://jinja.pocoo.org/ Jinja2> template+language.++Ginger aims to be as close to the original Jinja language as possible, but+avoiding blatant pythonisms and features that make little sense outside of+an impure dynamic host language context, especially when this would require+sacrificing runtime performance.+-}++module Text.Ginger+(+-- * Template Syntax+-- ** Minimal example template+-- | > <!DOCTYPE html>+-- > <html>+-- > <head>+-- > <title>{{ title }}</title>+-- > </head>+-- > {# This is a comment. Comments are removed from the output. #}+-- > <body>+-- > <menu id="nav-main">+-- > {% for item in navigation %}+-- > <li><a href="{{ item.url }}">{{ item.label }}</a></li>+-- > {% endfor %}+-- > </menu>+-- > <div class="layout-content-main">+-- > <h1>{{ title }}</h1>+-- > {{ body }}+-- > </div>+-- > </body>+-- > </html>++-- There are two kinds of delimiters. `{% ... %}` and `{{ ... }}`. The first+-- one is used to execute statements such as for-loops or assign values, the+-- latter prints the result of an expression to the template.++-- /Not implemented yet/: Jinja2 allows the programmer to override the default+-- tags from @{% %}@ and @{{ }}@ to different tokens, e.g. @\<% %\>@ and @\<\<+-- \>\>@. Ginger does not currently support this.++-- ** Variables+-- | You can mess around with the variables in templates provided they are+-- passed in by the application. Variables may have attributes or elements+-- on them you can access too. What attributes a variable has depends+-- heavily on the application providing that variable.++-- | You can use a dot (@.@) to access attributes of a variable, but+-- alternatively the so-called “subscript” syntax (@[]@) can be used. The+-- following lines do the same thing:++-- | @+-- {{ foo.bar }}+-- {{ foo['bar'] }}+-- @++-- | It’s important to know that the curly braces are /not/ part of the+-- variable, but the print statement. If you access variables inside tags+-- don’t put the braces around them.++-- | If a variable or attribute does not exist you will get back an undefined+-- value. What you can do with that kind of value depends on the+-- application configuration: the default behavior is that it evaluates to+-- an empty string if printed and that you can iterate over it, but every+-- other operation fails.++-- ** Expressions+-- | Variables aren't the only thing that can go inside @{{ ... }}@; any valid+-- Ginger expression can be used, and expressions can be constructed in many+-- different ways. Note that all expressions are case sensitive: @null@ and+-- @Null@ are not the same thing.+-- Currently, the following constructs are available:++-- *** Simple (\"Atomic\") Expressions+-- **** Variable reference+-- | Look up a variable in the current scope and return its value.++-- | > {{ username }}++-- **** String literals+-- | A constant string. Strings can be single- or double-quoted.++-- | > {{ "Hello, world!" }}++-- **** Numeric literals+-- | Numeric literals can be given in integer or decimal format:++-- | @+-- {{ 21 }}+-- {{ 44.5 }}+-- @++-- **** Boolean literals+-- | There are two boolean values, @true@ and @false@. You will not normally+-- need to use them, as they are produced by boolean expressions such as+-- comparisons, but they can be useful occasionally.++-- | @+-- {{ true }}+-- {{ false }}+-- @++-- **** The Null literal+-- | Represents the special /null/ value, which is used to signal the absence+-- of a result or value. Looking up non-existent scope variables, for example,+-- will produce Null.++-- | > {{ null }}++-- *** Data Structures+-- **** List Literals+-- | A list literal consists of a comma-separated list of expressions between+-- square brackets:++-- | > {{ [ foo, "bar", 1234 ] }}++-- | Lists can contain any kind of expression, including other lists, so you can+-- nest them:++-- | > {{ [ foo, [ 1, 2, 3 ], "baz" ] }}++-- **** Object Literals+-- | An object is an unsorted key/value container, declared like this:++-- | > {{ { "foo": "bar", "baz": "quux" } }}++-- | Objects, like lists, can contain any kind of value. The keys, however, are+-- restricted to strings; you can define them using any expression you like,+-- but they are always converted to strings when inserting items into the+-- container. This means that the following is valid:++-- | > {{ { ["foo", 1]: "bar" } }}++-- | It will, however, produce the same object as the following:++-- | > {{ { "foo1": "bar" } }}++-- | That's because converting @[\"foo\", 1]@ to a string produces @\"foo1\"@, and+-- that is used as the key.++-- *** Parentheses+-- | Parentheses can be used to group expression constructs to override default+-- precedence. Excess parentheses are simply ignored.++-- *** Unary operators+-- **** Function calls+-- | When an expression evaluates to a function, you can call it using a list+-- of arguments between parentheses. Most of the time, the function itself just+-- comes from a scope variable, so a function call typically looks like this:++-- | > {{ print(x, "hello!") }}++-- | However, anything that returns a function can be called as a function:++-- | > {{ system.console['log']("hello!") }}++-- **** Filter expressions+-- | Any function that takes at least one argument can be called through the+-- alternative filter syntax instead:++-- | > {{ x|print }}++-- | This is equivalent to:++-- | > {{ print(x) }}++-- | Filters can take arguments:++-- | > {{ x|append("foobar") }}++-- | This is equivalent to:++-- | > {{ append(x, "foobar") }}++-- | /Deviation from Jinja2:/ Ginger does not distinguish between filters and+-- functions at the semantics level; any function can be called as a filter,+-- and vv., and the filter syntax is merely a syntactic variant of a function+-- call.++-- * Haskell API+-- ** General+-- | On the Haskell side of things, executing a template is a two-step process.+-- First, template source code is parsed into a 'Template' data structure,+-- which is then fed to 'runGinger' or 'runGingerT'.++-- ** Parsing+-- | Because Ginger templates can include other templates, the parser needs a way of+-- resolving template names. Instead of hard-wiring the parser into 'IO' though,+-- Ginger will work on any Monad type, but requires the caller to provide a+-- suitable template resolver function. For 'IO', the resolver would typically+-- load a file from a template directory, but other monads might have access to+-- some sort of cache, or expose template compiled into a program, or simply+-- return 'Nothing' unconditionally to disable any and all imports. A suitable+-- example implementation for 'IO' would look like this:++-- | > loadFile fn = openFile fn ReadMode >>= hGetContents+-- > +-- > loadFileMay fn =+-- > tryIOError (loadFile fn) >>= \e ->+-- > case e of+-- > Right contents ->+-- > return (Just contents)+-- > Left err -> do+-- > print err -- remove this line if you want to fail silently+-- > return Nothing++-- | (Taken from @cli/GingerCLI.hs@). This interprets the template name as a+-- filename relative to the CWD, and returns the file contents on success or+-- 'Nothing' if there is any error.++-- | If you don't need a monadic context for resolving includes (e.g. because you+-- have pre-loaded all template sources), you can use the pure 'parseGinger'+-- flavor, which does not rely on a host monad.+ module Text.Ginger.Parse+-- ** Running+-- | The core function for running a template is 'runGinger' (or its monadic+-- flavor 'runGingerT'); in order to pass an initial context to the template+-- engine, pass a suitable 'GingerContext', which you can create using the+-- 'makeContext' / 'makeContextM' functions.++-- | An example call (for running a template in 'IO') would look something like+-- this:++-- > runGingerT (makeContextM scopeLookup (putStr . Text.unpack . htmlSource)) tpl+, module Text.Ginger.Run+-- ** Other concerns+-- | Ginger's unitype value+, module Text.Ginger.GVal+-- | The data structures used to represent templates, statements and+-- expressions internally.+, module Text.Ginger.AST+)+where+import Text.Ginger.Parse+import Text.Ginger.AST+import Text.Ginger.Run+import Text.Ginger.GVal++
+ src/Text/Ginger/AST.hs view
@@ -0,0 +1,61 @@+-- | Implements Ginger's Abstract Syntax Tree.+module Text.Ginger.AST+where++import Data.Text (Text)+import qualified Data.Text as Text+import Text.Ginger.Html+import Data.Scientific (Scientific)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+++-- | A context variable name.+type VarName = Text++-- | Top-level data structure, representing a fully parsed template.+data Template+ = Template+ { templateBody :: Statement+ , templateBlocks :: HashMap VarName Block+ , templateParent :: Maybe Template+ }+ deriving (Show)++-- | A macro definition ( {% macro %}+data Macro+ = Macro { macroArgs :: [VarName], macroBody :: Statement }+ deriving (Show)++-- | A block definition ( {% block %}+data Block+ = Block { blockBody :: Statement } -- TODO: scoped blocks+ deriving (Show)++-- | Ginger statements.+data Statement+ = MultiS [Statement] -- ^ A sequence of multiple statements+ | ScopedS Statement -- ^ Run wrapped statement in a local scope+ | LiteralS Html -- ^ Literal output (anything outside of any tag)+ | InterpolationS Expression -- ^ {{ expression }}+ | IfS Expression Statement Statement -- ^ {% if expression %}statement{% else %}statement{% endif %}+ | ForS (Maybe VarName) VarName Expression Statement -- ^ {% for index, varname in expression %}statement{% endfor %}+ | SetVarS VarName Expression -- ^ {% set varname = expr %}+ | DefMacroS VarName Macro -- ^ {% macro varname %}statements{% endmacro %}+ | BlockRefS VarName+ | PreprocessedIncludeS Template -- ^ {% include "template" %}+ | NullS -- ^ The do-nothing statement (NOP)+ deriving (Show)++-- | Expressions, building blocks for the expression minilanguage.+data Expression+ = StringLiteralE Text -- ^ String literal expression: "foobar"+ | NumberLiteralE Scientific -- ^ Numeric literal expression: 123.4+ | BoolLiteralE Bool -- ^ Boolean literal expression: true+ | NullLiteralE -- ^ Literal null+ | VarE VarName -- ^ Variable reference: foobar+ | ListE [Expression] -- ^ List construct: [ expr, expr, expr ]+ | ObjectE [(Expression, Expression)] -- ^ Object construct: { expr: expr, expr: expr, ... }+ | MemberLookupE Expression Expression -- ^ foo[bar] (also dot access)+ | CallE Expression [(Maybe Text, Expression)] -- ^ foo(bar=baz, quux)+ deriving (Show)
+ src/Text/Ginger/GVal.hs view
@@ -0,0 +1,341 @@+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}++-- | GVal is a generic unitype value, representing the kind of values that+-- Ginger can understand.+--+-- Most of the types in this module are parametrized over an 'm' type, which+-- is the host monad for template execution, as passed to 'runGingerT'.+module Text.Ginger.GVal+where++import Prelude ( (.), ($), (==), (/=)+ , (++), (+), (-), (*), (/), div+ , (>>=), return+ , undefined, otherwise, id, const+ , Maybe (..)+ , Bool (..)+ , Either (..)+ , Char+ , Int+ , Integer+ , Double+ , Show, show+ , Integral+ , fromIntegral, floor+ , not+ , fst, snd+ , Monad+ )+import qualified Prelude+import qualified Data.List as List+import Data.Maybe ( fromMaybe, catMaybes, isJust )+import Data.Text (Text)+import Data.String (IsString, fromString)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.List as List+import Safe (readMay, atMay)+import Data.Monoid+import Data.Scientific ( Scientific+ , floatingOrInteger+ , toBoundedInteger+ )+import Control.Applicative+import qualified Data.Aeson as JSON+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import qualified Data.Vector as Vector+import Control.Monad ( forM, mapM )+import Control.Monad.Trans (MonadTrans, lift)+import Data.Default (Default, def)++import Text.Ginger.Html++-- | A function that can be called from within a template execution context.+type Function m = [(Maybe Text, GVal m)] -> m (GVal m)++-- | Match arguments passed to a function at runtime against a list of declared+-- argument names.+-- @matchFuncArgs argNames argsPassed@ returns @(matchedArgs, positionalArgs, namedArgs)@,+-- where @matchedArgs@ is a list of arguments matched against declared names+-- (by name or by position), @positionalArgs@ are the unused positional+-- (unnamed) arguments, and @namedArgs@ are the unused named arguments.+matchFuncArgs :: [Text] -> [(Maybe Text, GVal m)] -> (HashMap Text (GVal m), [GVal m], HashMap Text (GVal m))+matchFuncArgs names args =+ (matched, positional, named)+ where+ positionalRaw = [ v | (Nothing, v) <- args ]+ namedRaw = HashMap.fromList [ (n, v) | (Just n, v) <- args ]+ fromPositional = Prelude.zip names positionalRaw+ numPositional = Prelude.length fromPositional+ namesRemaining = Prelude.drop numPositional names+ positional = Prelude.drop numPositional positionalRaw+ fromNamed = catMaybes $ (List.map lookupName namesRemaining)+ lookupName n = do+ v <- HashMap.lookup n namedRaw+ return (n, v)+ matched = HashMap.fromList $ fromPositional ++ fromNamed+ named = HashMap.difference namedRaw (HashMap.fromList fromNamed)++-- | Ginger value.+data GVal m =+ GVal+ { asList :: Maybe [GVal m]+ , asDictItems :: Maybe [(Text, GVal m)]+ , asLookup :: Maybe (Text -> Maybe (GVal m))+ , asHtml :: Html+ , asText :: Text+ , asBoolean :: Bool+ , asNumber :: Maybe Scientific+ , asFunction :: Maybe (Function m)+ , length :: Maybe Int+ , isNull :: Bool+ }++isList :: GVal m -> Bool+isList = isJust . asList++isDict :: GVal m -> Bool+isDict = isJust . asDictItems++-- | The default 'GVal' is equivalent to NULL.+instance Default (GVal m) where+ def = GVal+ { asList = Nothing+ , asDictItems = Nothing+ , asLookup = Nothing+ , asHtml = unsafeRawHtml ""+ , asText = ""+ , asBoolean = False+ , asNumber = Nothing+ , asFunction = Nothing+ , isNull = True+ , length = Nothing+ }++-- | Types that implement conversion to 'GVal'+class ToGVal m a where+ toGVal :: a -> GVal m++-- | Trivial instance for 'GVal' itself+instance ToGVal m (GVal m) where+ toGVal = id++-- | For convenience, 'Show' is implemented in a way that looks similar to+-- JavaScript / JSON+instance Show (GVal m) where+ show v+ | isNull v = "null"+ | isJust (asFunction v) = "<<function>>"+ | isJust (asDictItems v) = "{" <> (mconcat . List.intersperse ", " $ [ show k <> ": " <> show v | (k, v) <- fromMaybe [] (asDictItems v) ]) <> "}"+ | isJust (asList v) = "[" <> (mconcat . List.intersperse ", " . Prelude.map show $ fromMaybe [] (asList v)) <> "]"+ | isJust (asNumber v) =+ case floatingOrInteger <$> asNumber v :: Maybe (Either Double Integer) of+ Just (Left x) -> show (asNumber v)+ Just (Right x) -> show x+ Nothing -> ""+ | otherwise = show $ asText v++-- | Converting to HTML hooks into the ToHtml instance for 'Text' for most tags.+-- Tags that have no obvious textual representation render as empty HTML.+instance ToHtml (GVal m) where+ toHtml = asHtml++-- | Treat a 'GVal' as a flat list and look up a value by integer index.+-- If the value is not a List, or if the index exceeds the list length,+-- return 'Nothing'.+lookupIndex :: Int -> GVal m -> Maybe (GVal m)+lookupIndex = lookupIndexMay . Just++-- | Helper function; look up a value by an integer index when the index may or+-- may not be available. If no index is given, return 'Nothing'.+lookupIndexMay :: Maybe Int -> GVal m -> Maybe (GVal m)+lookupIndexMay i v = do+ index <- i+ items <- asList v+ atMay items index++lookupKey :: Text -> GVal m -> Maybe (GVal m)+lookupKey k v = do+ lf <- asLookup v+ lf k++-- | Loosely-typed lookup: try dictionary-style lookup first (treat index as+-- a string, and container as a dictionary), if that doesn't yield anything+-- (either because the index is not string-ish, or because the container+-- doesn't provide dictionary-style access), try index-based lookup.+lookupLoose :: GVal m -> GVal m -> Maybe (GVal m)+lookupLoose k v =+ lookupKey (asText k) v <|> lookupIndexMay (floor <$> asNumber k) v++-- | Treat a 'GVal' as a dictionary and list all the keys, with no particular+-- ordering.+keys :: GVal m -> Maybe [Text]+keys v = Prelude.map fst <$> asDictItems v++-- | Convert a 'GVal' to a number.+toNumber :: GVal m -> Maybe Scientific+toNumber = asNumber++-- | Convert a 'GVal' to an 'Int'.+-- The conversion will fail when the value is not numeric, and also if+-- it is too large to fit in an 'Int'.+toInt :: GVal m -> Maybe Int+toInt x = toNumber x >>= toBoundedInteger++-- | Loose cast to boolean.+--+-- Numeric zero, empty strings, empty lists, empty objects, 'Null', and boolean+-- 'False' are considered falsy, anything else (including functions) is+-- considered true-ish.+toBoolean :: GVal m -> Bool+toBoolean = asBoolean++-- | Dynamically cast to a function.+-- This yields 'Just' a 'Function' if the value is a function, 'Nothing' if+-- it's not.+toFunction :: GVal m -> Maybe (Function m)+toFunction = asFunction++-- | Turn a 'Function' into a 'GVal'+fromFunction :: Function m -> GVal m+fromFunction f =+ def+ { asHtml = html ""+ , asText = ""+ , asBoolean = True+ , isNull = False+ , asFunction = Just f+ }++instance ToGVal m v => ToGVal m (Maybe v) where+ toGVal Nothing = def+ toGVal (Just x) = toGVal x++instance ToGVal m v => ToGVal m [v] where+ toGVal xs = helper (Prelude.map toGVal xs)+ where+ helper :: [GVal m] -> GVal m+ helper xs =+ def+ { asHtml = mconcat . Prelude.map asHtml $ xs+ , asText = mconcat . Prelude.map asText $ xs+ , asBoolean = not . List.null $ xs+ , isNull = False+ , asList = Just $ Prelude.map toGVal xs+ , length = Just $ Prelude.length xs+ }++instance ToGVal m v => ToGVal m (HashMap Text v) where+ toGVal xs = helper (HashMap.map toGVal xs)+ where+ helper :: HashMap Text (GVal m) -> GVal m+ helper xs =+ def+ { asHtml = mconcat . Prelude.map asHtml . HashMap.elems $ xs+ , asText = mconcat . Prelude.map asText . HashMap.elems $ xs+ , asBoolean = not . HashMap.null $ xs+ , isNull = False+ , asLookup = Just (\v -> HashMap.lookup v xs)+ , asDictItems = Just $ HashMap.toList xs+ }++instance ToGVal m Int where+ toGVal x =+ def+ { asHtml = html . Text.pack . show $ x+ , asText = Text.pack . show $ x+ , asBoolean = x /= 0+ , asNumber = Just . fromIntegral $ x+ , isNull = False+ }++instance ToGVal m Integer where+ toGVal x =+ def+ { asHtml = html . Text.pack . show $ x+ , asText = Text.pack . show $ x+ , asBoolean = x /= 0+ , asNumber = Just . fromIntegral $ x+ , isNull = False+ }++instance ToGVal m Scientific where+ toGVal x =+ def+ { asHtml = html $ scientificToText x+ , asText = scientificToText x+ , asBoolean = x /= 0+ , asNumber = Just x+ , isNull = False+ }++scientificToText :: Scientific -> Text+scientificToText x =+ Text.pack $ case floatingOrInteger x of+ Left x -> show x+ Right x -> show x++instance ToGVal m Bool where+ toGVal x =+ def+ { asHtml = if x then html "1" else html ""+ , asText = if x then "1" else ""+ , asBoolean = x+ , asNumber = Just $ if x then 1 else 0+ , isNull = False+ }++instance IsString (GVal m) where+ fromString x =+ def+ { asHtml = html . Text.pack $ x+ , asText = Text.pack x+ , asBoolean = not $ Prelude.null x+ , asNumber = readMay x+ , isNull = False+ , length = Just . Prelude.length $ x+ }++instance ToGVal m Text where+ toGVal x =+ def+ { asHtml = html x+ , asText = x+ , asBoolean = not $ Text.null x+ , asNumber = readMay . Text.unpack $ x+ , isNull = False+ }++instance ToGVal m LText.Text where+ toGVal x =+ def+ { asHtml = html (LText.toStrict x)+ , asText = LText.toStrict x+ , asBoolean = not $ LText.null x+ , asNumber = readMay . LText.unpack $ x+ , isNull = False+ }++instance ToGVal m Html where+ toGVal x =+ def+ { asHtml = x+ , asText = htmlSource x+ , asBoolean = not . Text.null . htmlSource $ x+ , asNumber = readMay . Text.unpack . htmlSource $ x+ , isNull = False+ }++-- | Convert Aeson 'Value's to 'GVal's over an arbitrary host monad. Because+-- JSON cannot represent functions, this conversion will never produce a+-- 'Function'.+instance ToGVal m JSON.Value where+ toGVal (JSON.Number n) = toGVal n+ toGVal (JSON.String s) = toGVal s+ toGVal (JSON.Bool b) = toGVal b+ toGVal (JSON.Null) = def+ toGVal (JSON.Array a) = toGVal $ Vector.toList a+ toGVal (JSON.Object o) = toGVal o
+ src/Text/Ginger/Html.hs view
@@ -0,0 +1,64 @@+-- | A HTML type, useful for implementing type-safe conversion between plain+-- text and HTML.+-- The HTML representation used here assumed Unicode throughout, and UTF-8+-- should be used as the encoding when sending @Html@ objects as responses to a+-- HTTP client.+{-#LANGUAGE GeneralizedNewtypeDeriving #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE FlexibleInstances #-}+module Text.Ginger.Html+( Html+, unsafeRawHtml+, html+, htmlSource+, ToHtml (..)+)+where++import Data.Text (Text)+import qualified Data.Text as Text+import Data.Monoid++-- | A chunk of HTML source.+newtype Html = Html { unHtml :: Text }+ deriving (Monoid, Show, Eq, Ord)++-- | Types that support conversion to HTML.+class ToHtml s where+ toHtml :: s -> Html++-- | Text is automatically HTML-encoded+instance ToHtml Text where+ toHtml = html++-- | String is automatically HTML-encoded and converted to 'Text'+instance ToHtml [Char] where+ toHtml = mconcat . map htmlEncodeChar++-- | Html itself is a trivial instance+instance ToHtml Html where+ toHtml = id++-- | Extract HTML source code from an @Html@ value.+htmlSource :: Html -> Text+htmlSource = unHtml++-- | Convert a chunk of HTML source code into an @Html@ value as-is. Note that+-- this bypasses any and all HTML encoding; the caller is responsible for+-- taking appropriate measures against XSS and other potential vulnerabilities.+-- In other words, the input to this function is considered pre-sanitized.+unsafeRawHtml :: Text -> Html+unsafeRawHtml = Html++-- | Safely convert plain text to HTML.+html :: Text -> Html+html = mconcat . map htmlEncodeChar . Text.unpack++-- | HTML-encode an individual character.+htmlEncodeChar :: Char -> Html+htmlEncodeChar '&' = Html "&"+htmlEncodeChar '"' = Html """+htmlEncodeChar '\'' = Html "'"+htmlEncodeChar '<' = Html "<"+htmlEncodeChar '>' = Html ">"+htmlEncodeChar c = Html $ Text.singleton c
+ src/Text/Ginger/Parse.hs view
@@ -0,0 +1,633 @@+{-#LANGUAGE TupleSections #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE ScopedTypeVariables #-}+-- | Ginger parser.+module Text.Ginger.Parse+( parseGinger+, parseGingerFile+, ParserError (..)+, IncludeResolver+, Source, SourceName+)+where++import Text.Parsec ( ParseError+ , sourceLine+ , sourceColumn+ , sourceName+ , ParsecT+ , runParserT+ , try, lookAhead+ , manyTill, oneOf, string, notFollowedBy, between, sepBy+ , eof, spaces, anyChar, char+ , option+ , unexpected+ , digit+ , getState, modifyState+ , (<?>)+ )+import Text.Parsec.Error ( errorMessages+ , errorPos+ , showErrorMessages+ )+import Text.Ginger.AST+import Text.Ginger.Html ( unsafeRawHtml )++import Control.Monad.Reader ( ReaderT+ , runReaderT+ , ask, asks+ )+import Control.Monad.Trans.Class ( lift )+import Control.Applicative+import Safe ( readMay )++import Data.Text (Text)+import Data.Maybe ( fromMaybe )+import Data.Scientific ( Scientific )+import qualified Data.Text as Text+import Data.List ( foldr, nub, sort )+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++import System.FilePath ( takeDirectory, (</>) )++-- | Input type for the parser (source code).+type Source = String++-- | A source identifier (typically a filename).+type SourceName = String++-- | Used to resolve includes. Ginger will call this function whenever it+-- encounters an {% include %}, {% import %}, or {% extends %} directive.+-- If the required source code is not available, the resolver should return+-- @Nothing@, else @Just@ the source.+type IncludeResolver m = SourceName -> m (Maybe Source)+++-- | Error information for Ginger parser errors.+data ParserError =+ ParserError+ { peErrorMessage :: String -- ^ Human-readable error message+ , peSourceName :: Maybe SourceName -- ^ Source name, if any+ , peSourceLine :: Maybe Int -- ^ Line number, if available+ , peSourceColumn :: Maybe Int -- ^ Column number, if available+ }+ deriving (Show)++-- | Helper function to create a Ginger parser error from a Parsec error.+fromParsecError :: ParseError -> ParserError+fromParsecError e =+ let pos = errorPos e+ sourceFilename =+ let sn = sourceName pos+ in if null sn then Nothing else Just sn+ in ParserError+ (dropWhile (== '\n') .+ showErrorMessages+ "or"+ "unknown parse error"+ "expecting"+ "unexpected"+ "end of input"+ $ errorMessages e)+ sourceFilename+ (Just $ sourceLine pos)+ (Just $ sourceColumn pos)+-- | Parse Ginger source from a file.+parseGingerFile :: Monad m => IncludeResolver m -> SourceName -> m (Either ParserError Template)+parseGingerFile resolve fn = do+ srcMay <- resolve fn+ case srcMay of+ Nothing -> return . Left $+ ParserError+ { peErrorMessage = "Template source not found: " ++ fn+ , peSourceName = Nothing+ , peSourceLine = Nothing+ , peSourceColumn = Nothing+ }+ Just src -> parseGinger resolve (Just fn) src+++data ParseContext m+ = ParseContext+ { pcResolve :: IncludeResolver m+ , pcCurrentSource :: Maybe SourceName+ }++data ParseState+ = ParseState+ { psBlocks :: HashMap VarName Block+ }++defParseState :: ParseState+defParseState =+ ParseState+ { psBlocks = HashMap.empty+ }++-- | Parse Ginger source from memory.+parseGinger :: Monad m => IncludeResolver m -> Maybe SourceName -> Source -> m (Either ParserError Template)+parseGinger resolve sn src = do+ result <- runReaderT (runParserT (templateP `before` eof) defParseState (fromMaybe "<<unknown>>" sn) src) (ParseContext resolve sn)+ case result of+ Right t -> return . Right $ t+ Left e -> return . Left $ fromParsecError e++type Parser m a = ParsecT String ParseState (ReaderT (ParseContext m) m) a++ignore :: Monad m => m a -> m ()+ignore = (>> return ())++getResolver :: Monad m => Parser m (IncludeResolver m)+getResolver = asks pcResolve++include :: Monad m => SourceName -> Parser m Statement+include sourceName = PreprocessedIncludeS <$> includeTemplate sourceName++-- include sourceName = templateBody <$> includeTemplate sourceName++includeTemplate :: Monad m => SourceName -> Parser m Template+includeTemplate sourceName = do+ resolver <- getResolver+ currentSource <- fromMaybe "" <$> asks pcCurrentSource+ let includeSourceName = takeDirectory currentSource </> sourceName+ pres <- lift . lift $ parseGingerFile resolver includeSourceName+ case pres of+ Right t -> return t+ Left err -> fail (show err)++reduceStatements :: [Statement] -> Statement+reduceStatements [] = NullS+reduceStatements (x:[]) = x+reduceStatements xs = MultiS xs++templateP :: Monad m => Parser m Template+templateP = derivedTemplateP <|> baseTemplateP++derivedTemplateP :: Monad m => Parser m Template+derivedTemplateP = do+ parentName <- try (spaces >> fancyTagP "extends" stringLiteralP)+ parentTemplate <- includeTemplate parentName+ blocks <- HashMap.fromList <$> many blockP+ return $ Template { templateBody = NullS, templateParent = Just parentTemplate, templateBlocks = blocks }++baseTemplateP :: Monad m => Parser m Template+baseTemplateP = do+ body <- statementsP+ blocks <- psBlocks <$> getState+ return $ Template { templateBody = body, templateParent = Nothing, templateBlocks = blocks }++statementsP :: Monad m => Parser m Statement+statementsP = do+ reduceStatements . filter (not . isNullS) <$> many (try statementP)+ where+ isNullS NullS = True+ isNullS _ = False++statementP :: Monad m => Parser m Statement+statementP = interpolationStmtP+ <|> commentStmtP+ <|> ifStmtP+ <|> setStmtP+ <|> forStmtP+ <|> includeP+ <|> macroStmtP+ <|> blockStmtP+ <|> callStmtP+ <|> scopeStmtP+ <|> literalStmtP++interpolationStmtP :: Monad m => Parser m Statement+interpolationStmtP = do+ try $ string "{{"+ spaces+ expr <- expressionP+ spaces+ string "}}"+ return $ InterpolationS expr++literalStmtP :: Monad m => Parser m Statement+literalStmtP = do+ txt <- manyTill anyChar endOfLiteralP++ case txt of+ [] -> unexpected "{{"+ _ -> return . LiteralS . unsafeRawHtml . Text.pack $ txt++endOfLiteralP :: Monad m => Parser m ()+endOfLiteralP =+ (ignore . lookAhead . try . string $ "{{") <|>+ (ignore . lookAhead $ openTagP) <|>+ (ignore . lookAhead $ openCommentP) <|>+ eof++commentStmtP :: Monad m => Parser m Statement+commentStmtP = do+ try $ openCommentP+ manyTill anyChar (try $ closeCommentP)+ return NullS++ifStmtP :: Monad m => Parser m Statement+ifStmtP = do+ condExpr <- fancyTagP "if" expressionP+ trueStmt <- statementsP+ falseStmt <- option NullS $ do+ try $ simpleTagP "else"+ statementsP+ simpleTagP "endif"+ return $ IfS condExpr trueStmt falseStmt++setStmtP :: Monad m => Parser m Statement+setStmtP = fancyTagP "set" setStmtInnerP++setStmtInnerP :: Monad m => Parser m Statement+setStmtInnerP = do+ name <- identifierP+ spaces+ char '='+ spaces+ val <- expressionP+ spaces+ return $ SetVarS name val++defineBlock :: VarName -> Block -> ParseState -> ParseState+defineBlock name block s =+ s { psBlocks = HashMap.insert name block (psBlocks s) }++blockStmtP :: Monad m => Parser m Statement+blockStmtP = do+ (name, block) <- blockP+ modifyState (defineBlock name block)+ return $ BlockRefS name++blockP :: Monad m => Parser m (VarName, Block)+blockP = do+ name <- fancyTagP "block" identifierP+ body <- statementsP+ fancyTagP "endblock" (optional $ string (Text.unpack name) >> spaces)+ return (name, Block body)++macroStmtP :: Monad m => Parser m Statement+macroStmtP = do+ (name, args) <- try $ fancyTagP "macro" macroHeadP+ body <- statementsP+ fancyTagP "endmacro" (optional $ string (Text.unpack name) >> spaces)+ return $ DefMacroS name (Macro args body)++macroHeadP :: Monad m => Parser m (VarName, [VarName])+macroHeadP = do+ name <- identifierP+ spaces+ args <- option [] $ groupP "(" ")" identifierP+ spaces+ return (name, args)++-- {% call (foo) bar(baz) %}quux{% endcall %}+--+-- is the same as:+--+-- {% scope %}+-- {% macro __lambda(foo) %}quux{% endmacro %}+-- {% set caller = __lambda %}+-- {{ bar(baz) }}+-- {% endscope %]+callStmtP :: Monad m => Parser m Statement+callStmtP = do+ (callerArgs, call) <- try $ fancyTagP "call" callHeadP+ body <- statementsP+ simpleTagP "endcall"+ return (+ ScopedS (+ MultiS [ DefMacroS "caller" (Macro callerArgs body)+ , InterpolationS call+ ]))++callHeadP :: Monad m => Parser m ([Text], Expression)+callHeadP = do+ callerArgs <- option [] $ groupP "(" ")" identifierP+ spaces+ call <- expressionP+ spaces+ return (callerArgs, call)++scopeStmtP :: Monad m => Parser m Statement+scopeStmtP =+ ScopedS <$>+ between+ (simpleTagP "scope")+ (simpleTagP "endscope")+ statementsP++forStmtP :: Monad m => Parser m Statement+forStmtP = do+ (iteree, varNameVal, varNameIndex) <- fancyTagP "for" forHeadP+ body <- statementsP+ simpleTagP "endfor"+ return $ ForS varNameIndex varNameVal iteree body++includeP :: Monad m => Parser m Statement+includeP = do+ sourceName <- fancyTagP "include" stringLiteralP+ include sourceName++forHeadP :: Monad m => Parser m (Expression, VarName, Maybe VarName)+forHeadP = try forHeadInP <|> forHeadAsP++forIteratorP :: Monad m => Parser m (VarName, Maybe VarName)+forIteratorP = try forIndexedIteratorP <|> try forSimpleIteratorP <?> "iteration variables"++forIndexedIteratorP :: Monad m => Parser m (VarName, Maybe VarName)+forIndexedIteratorP = do+ indexIdent <- identifierP+ spaces+ char ','+ spaces+ varIdent <- identifierP+ spaces+ return (varIdent, Just indexIdent)++forSimpleIteratorP :: Monad m => Parser m (VarName, Maybe VarName)+forSimpleIteratorP = do+ varIdent <- identifierP+ spaces+ return (varIdent, Nothing)++forHeadInP :: Monad m => Parser m (Expression, VarName, Maybe VarName)+forHeadInP = do+ (varIdent, indexIdent) <- forIteratorP+ spaces+ string "in"+ notFollowedBy identCharP+ spaces+ iteree <- expressionP+ return (iteree, varIdent, indexIdent)++forHeadAsP :: Monad m => Parser m (Expression, VarName, Maybe VarName)+forHeadAsP = do+ iteree <- expressionP+ spaces+ string "as"+ notFollowedBy identCharP+ spaces+ (varIdent, indexIdent) <- forIteratorP+ return (iteree, varIdent, indexIdent)++fancyTagP :: Monad m => String -> Parser m a -> Parser m a+fancyTagP tagName inner =+ between+ (try $ do+ openTagP+ string tagName+ spaces)+ closeTagP+ inner++simpleTagP :: Monad m => String -> Parser m ()+simpleTagP tagName = openTagP >> string tagName >> closeTagP++openCommentP :: Monad m => Parser m ()+openCommentP = openP '#'++closeCommentP :: Monad m => Parser m ()+closeCommentP = closeP '#'++openTagP :: Monad m => Parser m ()+openTagP = openP '%'++closeTagP :: Monad m => Parser m ()+closeTagP = closeP '%'++openP :: Monad m => Char -> Parser m ()+openP c = try (openWP c) <|> try (openNWP c)++openWP :: Monad m => Char -> Parser m ()+openWP c = ignore $ do+ spaces+ string [ '{', c, '-' ]+ spaces++openNWP :: Monad m => Char -> Parser m ()+openNWP c = ignore $ do+ string [ '{', c ]+ spaces++closeP :: Monad m => Char -> Parser m ()+closeP c = try (closeWP c) <|> try (closeNWP c)++closeWP :: Monad m => Char -> Parser m ()+closeWP c = ignore $ do+ spaces+ string [ '-', c, '}' ]+ spaces++closeNWP :: Monad m => Char -> Parser m ()+closeNWP c = ignore $ do+ spaces+ string [ c, '}' ]+ optional . ignore . char $ '\n'++expressionP :: Monad m => Parser m Expression+expressionP = comparativeExprP++operativeExprP :: forall m. Monad m => Parser m Expression -> [ (String, Text) ] -> Parser m Expression+operativeExprP operandP operators = do+ lhs <- operandP+ spaces+ tails <- many . try $ operativeTail+ return $ foldl (flip ($)) lhs tails+ where+ opChars :: [Char]+ opChars = nub . sort . concat . map fst $ operators+ operativeTail :: Parser m (Expression -> Expression)+ operativeTail = do+ funcName <-+ foldl (<|>) (fail "operator") $+ [ try (string op >> notFollowedBy (oneOf opChars)) >> return fn | (op, fn) <- operators ]+ spaces+ rhs <- operandP+ spaces+ return (\lhs -> CallE (VarE funcName) [(Nothing, lhs), (Nothing, rhs)])++comparativeExprP :: Monad m => Parser m Expression+comparativeExprP =+ operativeExprP+ additiveExprP+ [ ("==", "equals")+ ]++additiveExprP :: Monad m => Parser m Expression+additiveExprP =+ operativeExprP+ multiplicativeExprP+ [ ("+", "sum")+ , ("-", "difference")+ , ("~", "concat")+ ]++multiplicativeExprP :: Monad m => Parser m Expression+multiplicativeExprP =+ operativeExprP+ postfixExprP+ [ ("*", "product")+ , ("//", "int_ratio")+ , ("/", "ratio")+ , ("%", "modulo")+ ]++postfixExprP :: Monad m => Parser m Expression+postfixExprP = do+ base <- atomicExprP+ spaces+ postfixes <- many . try $ postfixP `before` spaces+ return $ foldl (flip ($)) base postfixes++postfixP :: Monad m => Parser m (Expression -> Expression)+postfixP = dotPostfixP+ <|> arrayAccessP+ <|> funcCallP+ <|> filterP++dotPostfixP :: Monad m => Parser m (Expression -> Expression)+dotPostfixP = do+ char '.'+ spaces+ i <- StringLiteralE <$> identifierP+ return $ \e -> MemberLookupE e i++arrayAccessP :: Monad m => Parser m (Expression -> Expression)+arrayAccessP = do+ i <- bracedP "[" "]" expressionP+ return $ \e -> MemberLookupE e i++funcCallP :: Monad m => Parser m (Expression -> Expression)+funcCallP = do+ args <- groupP "(" ")" funcArgP+ return $ \e -> CallE e args++funcArgP :: Monad m => Parser m (Maybe Text, Expression)+funcArgP = namedFuncArgP <|> positionalFuncArgP++namedFuncArgP :: Monad m => Parser m (Maybe Text, Expression)+namedFuncArgP = do+ name <- try $ identifierP `before` (between spaces spaces $ string "=")+ expr <- expressionP+ return (Just name, expr)++positionalFuncArgP :: Monad m => Parser m (Maybe Text, Expression)+positionalFuncArgP = try $ (Nothing,) <$> expressionP++filterP :: Monad m => Parser m (Expression -> Expression)+filterP = do+ char '|'+ spaces+ func <- atomicExprP+ args <- option [] $ groupP "(" ")" funcArgP+ return $ \e -> CallE func ((Nothing, e):args)++atomicExprP :: Monad m => Parser m Expression+atomicExprP = parenthesizedExprP+ <|> objectExprP+ <|> listExprP+ <|> stringLiteralExprP+ <|> numberLiteralExprP+ <|> varExprP++parenthesizedExprP :: Monad m => Parser m Expression+parenthesizedExprP =+ between+ (try . ignore $ char '(' >> spaces)+ (ignore $ char ')' >> spaces)+ expressionP++listExprP :: Monad m => Parser m Expression+listExprP = ListE <$> groupP "[" "]" expressionP++objectExprP :: Monad m => Parser m Expression+objectExprP = ObjectE <$> groupP "{" "}" expressionPairP++expressionPairP :: Monad m => Parser m (Expression, Expression)+expressionPairP = do+ a <- expressionP+ spaces+ char ':'+ spaces+ b <- expressionP+ spaces+ return (a, b)++groupP :: Monad m => String -> String -> Parser m a -> Parser m [a]+groupP obr cbr inner =+ bracedP obr cbr+ (sepBy (inner `before` spaces) (try $ string "," `before` spaces))++bracedP :: Monad m => String -> String -> Parser m a -> Parser m a+bracedP obr cbr =+ between+ (try . ignore $ string obr >> spaces)+ (ignore $ string cbr >> spaces)++varExprP :: Monad m => Parser m Expression+varExprP = do+ litName <- identifierP+ spaces+ return $ case litName of+ "true" -> BoolLiteralE True+ "false" -> BoolLiteralE False+ "null" -> NullLiteralE+ _ -> VarE litName++identifierP :: Monad m => Parser m Text+identifierP =+ Text.pack <$> (+ (:)+ <$> oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['_'])+ <*> many identCharP)++identCharP :: Monad m => Parser m Char+identCharP = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'])++stringLiteralExprP :: Monad m => Parser m Expression+stringLiteralExprP = do+ StringLiteralE . Text.pack <$> stringLiteralP++stringLiteralP :: Monad m => Parser m String+stringLiteralP = do+ d <- oneOf [ '\'', '\"' ]+ manyTill stringCharP (char d)++stringCharP :: Monad m => Parser m Char+stringCharP = do+ c1 <- anyChar+ case c1 of+ '\\' -> do+ c2 <- anyChar+ case c2 of+ 'n' -> return '\n'+ 'b' -> return '\b'+ 'v' -> return '\v'+ '0' -> return '\0'+ 't' -> return '\t'+ _ -> return c2+ _ -> return c1++numberLiteralExprP :: Monad m => Parser m Expression+numberLiteralExprP = do+ str <- numberLiteralP+ let nMay :: Maybe Scientific+ nMay = readMay str+ case nMay of+ Just n -> return . NumberLiteralE $ n+ Nothing -> fail $ "Failed to parse " ++ str ++ " as a number"++numberLiteralP :: Monad m => Parser m String+numberLiteralP = do+ sign <- option "" $ string "-"+ integral <- string "0" <|> ((:) <$> oneOf ['1'..'9'] <*> many digit)+ fractional <- option "" $ (:) <$> char '.' <*> many digit+ return $ sign ++ integral ++ fractional++followedBy :: Monad m => m b -> m a -> m a+followedBy b a = a >>= \x -> (b >> return x)++before :: Monad m => m a -> m b -> m a+before = flip followedBy
+ src/Text/Ginger/Run.hs view
@@ -0,0 +1,399 @@+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TupleSections #-}+{-#LANGUAGE TypeSynonymInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE ScopedTypeVariables #-}+-- | Execute Ginger templates in an arbitrary monad.+module Text.Ginger.Run+( runGingerT+, runGinger+, GingerContext+, makeContext+, makeContextM+, Run, liftRun, liftRun2+)+where++import Prelude ( (.), ($), (==), (/=)+ , (+), (-), (*), (/), div+ , (||), (&&)+ , (++)+ , Show, show+ , undefined, otherwise+ , Maybe (..)+ , Bool (..)+ , Int+ , fromIntegral, floor+ , not+ , show+ , uncurry+ , seq+ , snd+ )+import qualified Prelude+import Data.Maybe (fromMaybe, isJust)+import qualified Data.List as List+import Text.Ginger.AST+import Text.Ginger.Html+import Text.Ginger.GVal++import Data.Text (Text)+import Data.String (fromString)+import qualified Data.Text as Text+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.Scientific (Scientific)+import Data.Scientific as Scientific+import Data.Default (def)+import Safe (readMay)++-- | Execution context. Determines how to look up variables from the+-- environment, and how to write out template output.+data GingerContext m+ = GingerContext+ { contextLookup :: VarName -> Run m (GVal (Run m))+ , contextWriteHtml :: Html -> Run m ()+ }++data RunState m+ = RunState+ { rsScope :: HashMap VarName (GVal (Run m))+ , rsCapture :: Html+ , rsCurrentTemplate :: Template -- the template we are currently running+ , rsCurrentBlockName :: Maybe Text -- the name of the innermost block we're currently in+ }++unaryFunc :: forall m. (Monad m) => (GVal (Run m) -> GVal (Run m)) -> Function (Run m)+unaryFunc f [] = return def+unaryFunc f ((_, x):[]) = return (f x)++ignoreArgNames :: ([a] -> b) -> ([(c, a)] -> b)+ignoreArgNames f args = f (Prelude.map snd args)++variadicNumericFunc :: Monad m => Scientific -> ([Scientific] -> Scientific) -> [(Maybe Text, GVal (Run m))] -> Run m (GVal (Run m))+variadicNumericFunc zero f args =+ return . toGVal . f $ args'+ where+ args' :: [Scientific]+ args' = Prelude.map (fromMaybe zero . asNumber . snd) args++variadicStringFunc :: Monad m => ([Text] -> Text) -> [(Maybe Text, GVal (Run m))] -> Run m (GVal (Run m))+variadicStringFunc f args =+ return . toGVal . f $ args'+ where+ args' :: [Text]+ args' = Prelude.map (asText . snd) args++defRunState :: forall m. Monad m => Template -> RunState m+defRunState tpl =+ RunState+ { rsScope = HashMap.fromList scope+ , rsCapture = html ""+ , rsCurrentTemplate = tpl+ , rsCurrentBlockName = Nothing+ }+ where+ scope :: [(Text, GVal (Run m))]+ scope =+ [ ("raw", fromFunction gfnRawHtml)+ , ("length", fromFunction . unaryFunc $ toGVal . length)+ , ("str", fromFunction . unaryFunc $ toGVal . asText)+ , ("num", fromFunction . unaryFunc $ toGVal . asNumber)+ , ("iterable", fromFunction . unaryFunc $ toGVal . (\x -> isList x || isDict x))+ , ("show", fromFunction . unaryFunc $ fromString . show)+ , ("default", fromFunction gfnDefault)+ , ("sum", fromFunction . variadicNumericFunc 0 $ Prelude.sum)+ , ("difference", fromFunction . variadicNumericFunc 0 $ difference)+ , ("concat", fromFunction . variadicStringFunc $ mconcat)+ , ("product", fromFunction . variadicNumericFunc 1 $ Prelude.product)+ , ("ratio", fromFunction . variadicNumericFunc 1 $ Scientific.fromFloatDigits . ratio . Prelude.map Scientific.toRealFloat)+ , ("int_ratio", fromFunction . variadicNumericFunc 1 $ fromIntegral . intRatio . Prelude.map Prelude.floor)+ , ("modulo", fromFunction . variadicNumericFunc 1 $ fromIntegral . modulo . Prelude.map Prelude.floor)+ , ("equals", fromFunction gfnEquals)+ ]++ gfnRawHtml :: Function (Run m)+ gfnRawHtml = unaryFunc (toGVal . unsafeRawHtml . asText)++ gfnDefault :: Function (Run m)+ gfnDefault [] = return def+ gfnDefault ((_, x):xs)+ | asBoolean x = return x+ | otherwise = gfnDefault xs++ gfnEquals :: Function (Run m)+ gfnEquals [] = return $ toGVal True+ gfnEquals (x:[]) = return $ toGVal True+ gfnEquals (x:xs) =+ return . toGVal $ Prelude.all ((snd x `looseEquals`) . snd) xs++ looseEquals :: GVal (Run m) -> GVal (Run m) -> Bool+ looseEquals a b+ | isJust (asFunction a) || isJust (asFunction b) = False+ | isJust (asList a) /= isJust (asList b) = False+ | isJust (asDictItems a) /= isJust (asDictItems b) = False+ -- Both numbers: do numeric comparison+ | isJust (asNumber a) && isJust (asNumber b) = asNumber a == asNumber b+ -- If either is NULL, the other must be falsy+ | isNull a || isNull b = asBoolean a == asBoolean b+ | otherwise = asText a == asText b++ difference :: Prelude.Num a => [a] -> a+ difference (x:xs) = x - Prelude.sum xs+ difference [] = 0++ ratio :: (Show a, Prelude.Fractional a, Prelude.Num a) => [a] -> a+ ratio (x:xs) = x / Prelude.product xs+ ratio [] = 0++ intRatio :: (Prelude.Integral a, Prelude.Num a) => [a] -> a+ intRatio (x:xs) = x `Prelude.div` Prelude.product xs+ intRatio [] = 0++ modulo :: (Prelude.Integral a, Prelude.Num a) => [a] -> a+ modulo (x:xs) = x `Prelude.mod` Prelude.product xs+ modulo [] = 0++-- | Create an execution context for runGingerT.+-- Takes a lookup function, which returns ginger values into the carrier monad+-- based on a lookup key, and a writer function (outputting HTML by whatever+-- means the carrier monad provides, e.g. @putStr@ for @IO@, or @tell@ for+-- @Writer@s).+makeContextM :: (Monad m, Functor m) => (VarName -> Run m (GVal (Run m))) -> (Html -> m ()) -> GingerContext m+makeContextM l w = GingerContext l (liftRun2 w)++liftLookup :: (Monad m, ToGVal (Run m) v) => (VarName -> m v) -> VarName -> Run m (GVal (Run m))+liftLookup f k = do+ v <- liftRun $ f k+ return . toGVal $ v++-- | Create an execution context for runGinger.+-- The argument is a lookup function that maps top-level context keys to ginger+-- values.+makeContext :: (VarName -> GVal (Run (Writer Html))) -> GingerContext (Writer Html)+makeContext l =+ makeContextM+ (return . l)+ tell++-- | Purely expand a Ginger template. @v@ is the type for Ginger values.+runGinger :: GingerContext (Writer Html) -> Template -> Html+runGinger context template = execWriter $ runGingerT context template++-- | Monadically run a Ginger template. The @m@ parameter is the carrier monad,+-- the @v@ parameter is the type for Ginger values.+runGingerT :: (Monad m, Functor m) => GingerContext m -> Template -> m ()+runGingerT context tpl = runReaderT (evalStateT (runTemplate tpl) (defRunState tpl)) context++-- | Internal type alias for our template-runner monad stack.+type Run m = StateT (RunState m) (ReaderT (GingerContext m) m)++-- | Lift a value from the host monad @m@ into the 'Run' monad.+liftRun :: Monad m => m a -> Run m a+liftRun = lift . lift++-- | Lift a function from the host monad @m@ into the 'Run' monad.+liftRun2 :: Monad m => (a -> m b) -> a -> Run m b+liftRun2 f x = liftRun $ f x++-- | Find the effective base template of an inheritance chain+baseTemplate :: Template -> Template+baseTemplate t =+ case templateParent t of+ Nothing -> t+ Just p -> baseTemplate p++-- | Run a template.+runTemplate :: (Monad m, Functor m) => Template -> Run m ()+runTemplate = runStatement . templateBody . baseTemplate++-- | Run an action within a different template context.+withTemplate :: (Monad m, Functor m) => Template -> Run m a -> Run m a+withTemplate tpl a = do+ oldTpl <- gets rsCurrentTemplate+ oldBlockName <- gets rsCurrentBlockName+ modify (\s -> s { rsCurrentTemplate = tpl, rsCurrentBlockName = Nothing })+ result <- a+ modify (\s -> s { rsCurrentTemplate = oldTpl, rsCurrentBlockName = oldBlockName })+ return result++-- | Run an action within a block context+withBlockName :: (Monad m, Functor m) => VarName -> Run m a -> Run m a+withBlockName blockName a = do+ oldBlockName <- gets rsCurrentBlockName+ modify (\s -> s { rsCurrentBlockName = Just blockName })+ result <- a+ modify (\s -> s { rsCurrentBlockName = oldBlockName })+ return result++lookupBlock :: (Monad m, Functor m) => VarName -> Run m Block+lookupBlock blockName = do+ tpl <- gets rsCurrentTemplate+ let blockMay = resolveBlock blockName tpl+ case blockMay of+ Nothing -> fail $ "Block " <> (Text.unpack blockName) <> " not defined"+ Just block -> return block+ where+ resolveBlock :: VarName -> Template -> Maybe Block+ resolveBlock name tpl =+ case HashMap.lookup name (templateBlocks tpl) of+ Just block ->+ return block -- Found it!+ Nothing ->+ templateParent tpl >>= resolveBlock name++-- | Run one statement.+runStatement :: (Monad m, Functor m) => Statement -> Run m ()+runStatement NullS = return ()+runStatement (MultiS xs) = forM_ xs runStatement+runStatement (LiteralS html) = echo html+runStatement (InterpolationS expr) = runExpression expr >>= echo+runStatement (IfS condExpr true false) = do+ cond <- runExpression condExpr+ runStatement $ if toBoolean cond then true else false++runStatement (SetVarS name valExpr) = do+ val <- runExpression valExpr+ setVar name val++runStatement (DefMacroS name macro) = do+ let val = macroToGVal macro+ setVar name val++runStatement (BlockRefS blockName) = do+ block <- lookupBlock blockName+ withBlockName blockName $+ runStatement (blockBody block)++runStatement (ScopedS body) = withLocalScope runInner+ where+ runInner :: (Functor m, Monad m) => Run m ()+ runInner = runStatement body++runStatement (ForS varNameIndex varNameValue itereeExpr body) = do+ iteree <- runExpression itereeExpr+ let iterPairs =+ if isJust (asDictItems iteree)+ then [ (toGVal k, v) | (k, v) <- fromMaybe [] (asDictItems iteree) ]+ else Prelude.zip (Prelude.map toGVal ([0..] :: [Int])) (fromMaybe [] (asList iteree))+ withLocalScope $ forM_ iterPairs iteration+ where+ iteration (index, value) = do+ setVar varNameValue value+ case varNameIndex of+ Nothing -> return ()+ Just n -> setVar n index+ runStatement body++runStatement (PreprocessedIncludeS tpl) =+ withTemplate tpl $ runTemplate tpl++-- | Deeply magical function that converts a 'Macro' into a Function.+macroToGVal :: forall m. (Functor m, Monad m) => Macro -> GVal (Run m)+macroToGVal (Macro argNames body) =+ fromFunction f+ where+ f :: Function (Run m)+ -- Establish a local state to not contaminate the parent scope+ -- with function arguments and local variables, and;+ -- Establish a local context, where we override the HTML writer,+ -- rewiring it to append any output to the state's capture.+ f args =+ withLocalState . local (\c -> c { contextWriteHtml = appendCapture }) $ do+ clearCapture+ forM (HashMap.toList matchedArgs) (uncurry setVar)+ setVar "varargs" . toGVal $ positionalArgs+ setVar "kwargs" . toGVal $ namedArgs+ runStatement body+ -- At this point, we're still inside the local state, so the+ -- capture contains the macro's output; we now simply return+ -- the capture as the function's return value.+ toGVal <$> fetchCapture+ where+ matchArgs' :: [(Maybe Text, GVal (Run m))] -> (HashMap Text (GVal (Run m)), [GVal (Run m)], HashMap Text (GVal (Run m)))+ matchArgs' = matchFuncArgs argNames+ (matchedArgs, positionalArgs, namedArgs) = matchArgs' args+++-- | Helper function to run a State action with a temporary state, reverting+-- to the old state after the action has finished.+withLocalState :: (Monad m, MonadState s m) => m a -> m a+withLocalState a = do+ s <- get+ r <- a+ put s+ return r++-- | Helper function to run a Scope action with a temporary scope, reverting+-- to the old scope after the action has finished.+withLocalScope :: (Monad m) => Run m a -> Run m a+withLocalScope a = do+ scope <- gets rsScope+ r <- a+ modify (\s -> s { rsScope = scope })+ return r++setVar :: Monad m => VarName -> GVal (Run m) -> Run m ()+setVar name val = do+ vars <- gets rsScope+ let vars' = HashMap.insert name val vars+ modify (\s -> s { rsScope = vars' })++getVar :: Monad m => VarName -> Run m (GVal (Run m))+getVar key = do+ vars <- gets rsScope+ case HashMap.lookup key vars of+ Just val ->+ return val+ Nothing -> do+ l <- asks contextLookup+ l key++clearCapture :: Monad m => Run m ()+clearCapture = modify (\s -> s { rsCapture = unsafeRawHtml "" })++appendCapture :: Monad m => Html -> Run m ()+appendCapture h = modify (\s -> s { rsCapture = rsCapture s <> h })++fetchCapture :: Monad m => Run m Html+fetchCapture = gets rsCapture++-- | Run (evaluate) an expression and return its value into the Run monad+runExpression (StringLiteralE str) = return . toGVal $ str+runExpression (NumberLiteralE n) = return . toGVal $ n+runExpression (BoolLiteralE b) = return . toGVal $ b+runExpression (NullLiteralE) = return def+runExpression (VarE key) = getVar key+runExpression (ListE xs) = toGVal <$> forM xs runExpression+runExpression (ObjectE xs) = do+ items <- forM xs $ \(a, b) -> do+ l <- asText <$> runExpression a+ r <- runExpression b+ return (l, r)+ return . toGVal . HashMap.fromList $ items+runExpression (MemberLookupE baseExpr indexExpr) = do+ base <- runExpression baseExpr+ index <- runExpression indexExpr+ return . fromMaybe def . lookupLoose index $ base+runExpression (CallE funcE argsEs) = do+ args <- forM argsEs $+ \(argName, argE) -> (argName,) <$> runExpression argE+ func <- toFunction <$> runExpression funcE+ case func of+ Nothing -> return def+ Just f -> f args++-- | Helper function to output a HTML value using whatever print function the+-- context provides.+echo :: (Monad m, Functor m, ToHtml h) => h -> Run m ()+echo src = do+ p <- asks contextWriteHtml+ p (toHtml src)