diff --git a/CHANGELOG b/CHANGELOG
new file mode 100644
--- /dev/null
+++ b/CHANGELOG
@@ -0,0 +1,3 @@
+2.0.0.0
+
+- Initial release
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2025 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.
diff --git a/README.markdown b/README.markdown
new file mode 100644
--- /dev/null
+++ b/README.markdown
@@ -0,0 +1,180 @@
+# Ginger 2
+
+
+
+A Haskell implementation of the [Jinja2](https://jinja.palletsprojects.com/)
+template language.
+
+## Introduction
+
+Ginger2 provides most of the original Jinja2 template language, as much as that
+makes sense in a Haskell host application.
+
+We do, however, avoid some of the most blatant Pythonisms, especially where we
+felt the features in question were more of an accidental result of binding
+template constructs to Python constructs.
+
+We also add some optional features that are absent from the Python
+implementation, but that we felt useful and worth adding.
+
+## Installation
+
+Ginger is available from [Hackage](https://hackage.haskell.org/package/ginger2),
+and can be installed using the usual methods.
+
+### Installing with Cabal:
+
+ cabal install ginger2
+
+### Using as part of another project:
+
+Add the following to your `.cabal`'s `build-depends`:
+
+ ginger2 ^>=2.0.0
+
+## Template Syntax
+
+Template syntax largely follows
+[Jinja2](https://jinja.palletsprojects.com/en/stable/templates/).
+
+Important deviations are listed below.
+
+### Minimal example template
+
+
+
+
+ {{ title }}
+
+ {# This is a comment. Comments are removed from the output. #}
+
+
+
+
{{ title }}
+ {{ body }}
+
+
+
+
+There are three kinds of delimiters:
+
+- Interpolation, to inject values into the output; these default to `{{` and
+ `}}`
+- Flow Control, to create conditionals, loops, and other control constructs;
+ these default to `{%` and `%}`
+- Comments, which are removed from the output; these default to `{#` and `#}`.
+
+### Jinja syntax features absent from Ginger 2
+
+- The `{% raw %}` statement does not currently exist in Ginger 2.
+- Comments (`{#` `#}`) cannot currently be nested.
+- Encoding is automatic and cannot be disabled; however, the Ginger API
+ allows a programmer to change the encoding function, so it is possible to use
+ Ginger 2 to produce output in any textual output format.
+- Line statements (using a leading `#` to mark a line as a statement, instead
+ of `{% ... %}` markers).
+- Template objects (passing an expression to `extends` that evaluates to a
+ template, instead of passing a template name as a string).
+- Ginger 2 makes no distinction between mutable "lists" and immutable "tuples";
+ there are only immutable lists.
+
+### Jinja functions, filters, and tests absent in Ginger 2
+
+#### Functions/filters
+
+- `forceescape`
+- `format`
+- `groupby`
+- `indent`
+- `max`
+- `pprint`
+- `selectattr`
+- `slice`
+- `striptags`
+- `sum`
+- `random`
+- `rejectattr`
+- `reject`
+- `min`
+- `trim`
+- `truncate`
+- `unique`
+- `urlencode`
+- `urlize`
+- `wordwrap`
+- `xmlattr`
+
+#### Tests
+
+- `escaped` - Due to the way Ginger 2 handles HTML-encoding, this filter makes
+ no sense; Ginger 2 automatically tracks which values are "raw" data, and
+ which are encoded HTML source, and treats them appropriately, so there should
+ never be a need to test for this.
+- `sameas` - In Ginger 2, all values (except "namespaces" and native objects)
+ are immutable, and passed by-value; hence, there is no meaningful notion of
+ "being the same object", and testing for it makes no sense.
+
+## Haskell API
+
+The Haskell API is documented fully through Haddock documentation, available
+from [Hackage](https://hackage.haskell.org/package/ginger2). We'll just provide
+a short overview here.
+
+### Loading And Running A Template
+
+The most straightforward way to run a template is to use the `ginger` function,
+which is parametrized over an underlying "carrier" Monad, `m`, and takes the
+following arguments:
+
+- A `TemplateLoader`, a function that takes a template name and returns
+ template source. The provided `fileLoader` will work for the normal situation
+ of loading templates from source.
+- Parser options (`POptions`). The default options (`defPOptions`) will work
+ fine for most situations, but you can use this parameter to override parser
+ settings.
+- A `JinjaDialect`; this determines whether Ginger2 will be (mostly) faithful
+ to the original Jinja (`DialectJinja2`), or whether it will add
+ Ginger-specific functionality (`DialectGinger2`). The latter is recommended,
+ unless compatibility with Jinja is a concern.
+- An `Encoder`, which determines how raw data gets encoded to the output source
+ format. For HTML output, use `htmlEncoder`; if you want Ginger to not encode
+ anything and just output raw data, you can use `pure . Encoded`, which acts
+ as a "do-nothing encoder".
+- A template name. The exact meaning of the template name depends on the
+ template loader; for the `fileLoader`, template names should be filenames
+ relative to the file loader's initial path.
+- An initial set of defined variables (on top of the built-in ones). This is
+ what Jinja calls the "context"; the Ginger2 API however uses the term
+ "environment".
+
+### Working With Ginger Values
+
+The main data structure to represent Ginger values is `Value`; this type
+captures the "unitype" that Ginger uses internally.
+
+The `ToValue` and `FromValue` typeclasses can be used to marshal Haskell values
+to and from Ginger, or you can work with `Value`s directly.
+
+Other types that appear in the surface API are `Identifier` (represents a
+variable or attribute name) and `Scalar` (represents a "scalar" type, i.e.,
+`none`, booleans, numbers, strings, byte arrays, and encoded strings).
+
+### The `GingerT` Monad Transformer
+
+The `GingerT` transformer captures an execution context/environment in which
+Ginger templates (and template fragments) can be evaluated/run. It adds the
+following concerns to the transformed base monad:
+
+- Runtime errors (via `MonadExcept`)
+- Execution state (variables/scope, and some other stateful concerns)
+- Execution context (immutable configuration, including the encoder)
+
+However, in some cases, it is necessary to implement functionality in terms of
+the raw base monad, representing failures as `Either`, and passing in context
+and, where necessary, execution state, as arguments. This is especially true
+when adding user-defined Haskell functions or native Haskell objects into the
+execution environment.
diff --git a/cli/Main.hs b/cli/Main.hs
new file mode 100644
--- /dev/null
+++ b/cli/Main.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+{-# OPTIONS_GHC -Werror #-}
+
+module Main where
+
+import Language.Ginger
+import Language.Ginger.Interpret.Builtins (textBuiltin)
+import Language.Ginger.Value
+
+import qualified CMark
+import CMark (commonmarkToHtml)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import Options.Applicative
+import System.Directory (getCurrentDirectory)
+import System.FilePath (takeDirectory, takeFileName, takeExtension, () )
+import System.IO (hPutStrLn, stderr)
+
+import qualified Data.Yaml as YAML
+
+data EncoderChoice
+ = HtmlEncoder
+ | TextEncoder
+ | AutoEncoder
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+data ProgramOptions =
+ ProgramOptions
+ { poDataFiles :: [FilePath]
+ , poSourceFile :: Maybe FilePath
+ , poOutputFile :: Maybe FilePath
+ , poTrimBlocks :: BlockTrimming
+ , poStripBlocks :: BlockStripping
+ , poEncoder :: EncoderChoice
+ , poDialect :: JinjaDialect
+ }
+ deriving (Show, Eq)
+
+defProgramOptions :: ProgramOptions
+defProgramOptions =
+ ProgramOptions
+ { poDataFiles = []
+ , poSourceFile = Nothing
+ , poOutputFile = Nothing
+ , poTrimBlocks = pstateTrimBlocks defPOptions
+ , poStripBlocks = pstateStripBlocks defPOptions
+ , poEncoder = HtmlEncoder
+ , poDialect = DialectGinger2
+ }
+
+programOptions :: Parser ProgramOptions
+programOptions =
+ ProgramOptions
+ <$> many
+ (
+ argument str
+ ( metavar "DATAFILE"
+ <> help "JSON or YAML data file"
+ )
+ <|>
+ strOption
+ ( metavar "DATAFILE"
+ <> short 'd'
+ <> long "data-file"
+ <> help "JSON or YAML data file"
+ )
+ )
+ <*> option (Just <$> str)
+ ( long "template"
+ <> short 't'
+ <> metavar "TEMPLATE"
+ <> help "Template file (STDIN if not provided)"
+ <> value Nothing
+ )
+ <*> option (Just <$> str)
+ ( long "output"
+ <> short 'o'
+ <> metavar "OUTFILE"
+ <> help "Output file (STDOUT if not provided)"
+ <> value Nothing
+ )
+ <*> ( flag' TrimBlocks
+ ( long "trim-blocks"
+ <> help "Enable block trimming"
+ )
+ <|>
+ flag' NoTrimBlocks
+ ( long "no-trim-blocks"
+ <> help "Disable block trimming"
+ )
+ <|> pure (pstateTrimBlocks defPOptions)
+ )
+ <*> ( flag' StripBlocks
+ ( long "strip-blocks"
+ <> help "Enable block stripping"
+ )
+ <|>
+ flag' NoStripBlocks
+ ( long "no-strip-blocks"
+ <> help "Disable block stripping"
+ )
+ <|> pure (pstateStripBlocks defPOptions)
+ )
+ <*> option encoderReader
+ ( long "encoder"
+ <> metavar "ENCODER"
+ <> help
+ ( "Output encoding ('html', 'text', or 'auto'). " ++
+ "'auto' will guess encoding from output file extension, then " ++
+ "template file extension, then default to 'html'")
+ <> value AutoEncoder
+ )
+ <*> option dialectReader
+ ( long "dialect"
+ <> metavar "DIALECT"
+ <> help
+ ( "Jinja dialect. Valid options: " ++
+ "'jinja' (compatibility mode), " ++
+ "'ginger' (ginger2-specific extensions, default)"
+ )
+ <> value DialectGinger2
+ )
+
+encoderReader :: ReadM EncoderChoice
+encoderReader = eitherReader $ \case
+ "html" -> Right HtmlEncoder
+ "text" -> Right TextEncoder
+ "auto" -> Right AutoEncoder
+ s -> Left $ "Invalid encoder: " ++ show s
+
+dialectReader :: ReadM JinjaDialect
+dialectReader = eitherReader $ \case
+ "ginger" -> Right DialectGinger2
+ "ginger2" -> Right DialectGinger2
+
+ "jinja" -> Right DialectJinja2
+ "jinja2" -> Right DialectJinja2
+ "compat" -> Right DialectJinja2
+ s -> Left $ "Invalid dialect: " ++ show s
+
+
+
+main :: IO ()
+main = do
+ po <- execParser $
+ info (programOptions <**> helper)
+ ( fullDesc
+ <> header "ginger - command-line jinja2 template interpreter"
+ )
+ runWithOptions po
+
+fileOrStdinLoader :: FilePath -> TemplateLoader IO
+fileOrStdinLoader baseDir templateName =
+ case templateName of
+ "" -> Just <$> Text.getContents
+ n -> Just <$> Text.readFile (baseDir Text.unpack n)
+
+textEncoder :: Encoder IO
+textEncoder txt = do
+ pure $ Encoded txt
+
+loadDataFile :: FilePath -> IO (Map Identifier (Value IO))
+loadDataFile path = do
+ YAML.decodeFileThrow path
+
+runWithOptions :: ProgramOptions -> IO ()
+runWithOptions po = do
+ (baseDir, templateName) <- case poSourceFile po of
+ Nothing -> (,) <$> getCurrentDirectory <*> pure ""
+ Just path -> pure (takeDirectory path, Text.pack $ takeFileName path)
+ vars <- mconcat <$> mapM loadDataFile (poDataFiles po)
+ let encoder = case poEncoder po of
+ HtmlEncoder -> htmlEncoder
+ TextEncoder -> textEncoder
+ AutoEncoder ->
+ let outputExt = maybe "" takeExtension $ poOutputFile po
+ ext = case outputExt of
+ "" -> takeExtension (Text.unpack templateName)
+ _ -> outputExt
+ in case ext of
+ ".txt" -> textEncoder
+ ".text" -> textEncoder
+ _ -> htmlEncoder
+ ginger
+ (fileOrStdinLoader baseDir)
+ defPOptions
+ { pstateTrimBlocks = poTrimBlocks po
+ , pstateStripBlocks = poStripBlocks po
+ }
+ (poDialect po)
+ encoder
+ templateName
+ (vars <> extensions) >>= printResultTo (poOutputFile po)
+
+printResult :: Either RuntimeError Encoded -> IO ()
+printResult = printResultTo Nothing
+
+printResultTo :: Maybe FilePath -> Either RuntimeError Encoded -> IO ()
+printResultTo _ (Left err) =
+ hPutStrLn stderr $ prettyRuntimeError err
+printResultTo Nothing (Right output) =
+ Text.putStrLn $ encoded output
+printResultTo (Just outputPath) (Right output) =
+ Text.writeFile outputPath $ encoded output
+
+demo :: IO ()
+demo = runWithOptions $ defProgramOptions
+ { poSourceFile = Just "./test.html"
+ , poEncoder = TextEncoder
+ }
+
+extensions :: forall m. Monad m => Map Identifier (Value m)
+extensions = Map.fromList
+ [ ("markdown"
+ , textBuiltin
+ "extensions:markdown"
+ (Just ProcedureDoc
+ { procedureDocName = "markdown"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ "Markdown source (CommonMark)"
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "encoded")
+ , procedureDocDescription = "Convert CommonMark to HTML"
+ }
+ )
+ (EncodedV @m . Encoded . commonmarkToHtml [CMark.optSafe])
+ )
+ ]
diff --git a/ginger2.cabal b/ginger2.cabal
new file mode 100644
--- /dev/null
+++ b/ginger2.cabal
@@ -0,0 +1,106 @@
+cabal-version: 3.0
+name: ginger2
+version: 2.0.0.0
+synopsis: Jinja templates for Haskell
+description: Ginger2 approximates Jinja2 (https://jinja.palletsprojects.com/)
+ in Haskell.
+license: MIT
+license-file: LICENSE
+author: Tobias Dammers
+maintainer: tdammers@gmail.com
+copyright: 2025 Tobias Dammers
+category: Language
+build-type: Simple
+bug-reports: https://github.com/tdammers/ginger2/issues
+extra-doc-files: README.markdown
+ , CHANGELOG
+-- extra-source-files:
+
+source-repository head
+ type: git
+ location: https://github.com/tdammers/ginger2
+
+common warnings
+ ghc-options: -Wall
+
+library
+ import: warnings
+ exposed-modules: Language.Ginger
+ , Language.Ginger.AST
+ , Language.Ginger.Value
+ , Language.Ginger.Interpret
+ , Language.Ginger.Interpret.Builtins
+ , Language.Ginger.Interpret.DefEnv
+ , Language.Ginger.Interpret.Type
+ , Language.Ginger.Interpret.Eval
+ , Language.Ginger.Parse
+ , Language.Ginger.FileLoader
+ , Language.Ginger.Render
+ , Language.Ginger.RuntimeError
+ , Language.Ginger.SourcePosition
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base >=4.14.0.0 && <5
+ , aeson >=2.2.3.0 && <2.3
+ , array >=0.5.8 && <0.6
+ , base64-bytestring >=1.2.1.0 && <1.3
+ , bytestring >=0.12.2.0 && <0.13
+ , containers >=0.7 && <0.9
+ , filepath >=1.5.4.0 && <1.6
+ , megaparsec >=9.7.0 && <9.8
+ , mtl >=2.3.1 && <2.4
+ , regex-tdfa >=1.3.2.3 && <1.4
+ , scientific >=0.3.8 && <0.4
+ , SHA >=1.6.4.4 && <1.7
+ , tasty >=1.5.3 && <1.6
+ , tasty-quickcheck >=0.11.1 && <0.12
+ , text >=2.0 && <2.3
+ , time >=1.12 && <1.15
+ , vector >=0.13.2 && <0.14
+ hs-source-dirs: src
+ default-language: Haskell2010
+
+executable ginger2
+ import: warnings
+ main-is: Main.hs
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base >=4.14.0.0 && <5
+ , ginger2
+ , aeson >=2.2.3.0 && <2.3
+ , cmark >=0.6.1 && <0.7
+ , containers >=0.7 && <0.9
+ , directory >=1.3.9 && <1.4
+ , filepath >=1.5.4.0 && <1.6
+ , optparse-applicative >=0.18.1.0 && <0.19
+ , text >=2.0 && <2.3
+ , vector >=0.13.2 && <0.14
+ , yaml >=0.11.11 && <0.12
+ hs-source-dirs: cli
+ default-language: Haskell2010
+
+test-suite ginger-test
+ import: warnings
+ default-language: Haskell2010
+ -- other-extensions:
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Main.hs
+ other-modules: Language.Ginger.Value.Tests
+ , Language.Ginger.AST.Tests
+ , Language.Ginger.Interpret.Tests
+ , Language.Ginger.Parse.Tests
+ , Language.Ginger.TestUtils
+ build-depends: base >=4.14.0.0 && <5
+ , ginger2
+ , base64-bytestring >=1.2.1.0 && <1.3
+ , bytestring >=0.12.2.0 && <0.13
+ , containers >=0.7 && <0.9
+ , megaparsec >=9.7.0 && <9.8
+ , mtl >=2.3.1 && <2.4
+ , quickcheck-instances >=0.3.2 && <0.4
+ , tasty >=1.5.3 && <1.6
+ , tasty-quickcheck >=0.11.1 && <0.12
+ , tasty-hunit >=0.10.2 && <0.11
+ , text >= 2.0 && <2.3
+ , vector >=0.13.2 && <0.14
diff --git a/src/Language/Ginger.hs b/src/Language/Ginger.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Language.Ginger
+( -- * AST
+ Statement (..)
+, Expr (..)
+, Template (..)
+, Block (..)
+ -- * Representing Values
+, Value (..)
+, Scalar (..)
+, Encoded (..)
+, prettyRuntimeError
+, Identifier (..)
+ -- * Interpreting Templates
+, ginger
+, GingerT
+, Eval (..)
+, RuntimeError (..)
+, Context (..)
+, defContext
+, Env (..)
+, emptyEnv
+, defEnv
+, defVars
+, defVarsCompat
+ -- * Configuration
+, Encoder
+, htmlEncoder
+, JinjaDialect (..)
+ -- * Parser and Parser Options
+, POptions (..)
+, defPOptions
+, BlockTrimming (..)
+, BlockStripping (..)
+ -- * Template Loaders
+, TemplateLoader
+, fileLoader
+)
+where
+
+import Language.Ginger.AST
+import Language.Ginger.Value
+import Language.Ginger.Interpret
+import Language.Ginger.RuntimeError (prettyRuntimeError)
+import Language.Ginger.FileLoader
+ ( fileLoader
+ )
+import Language.Ginger.Parse
+ ( POptions (..)
+ , defPOptions
+ , BlockTrimming (..)
+ , BlockStripping (..)
+ )
+import qualified Language.Ginger.Parse as P
+import Language.Ginger.Interpret.DefEnv
+ ( htmlEncoder
+ , defVars
+ , defVarsCompat
+ )
+
+import Control.Monad.Trans (MonadTrans (..))
+import Control.Monad.Except (runExceptT, throwError)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Map.Strict (Map)
+
+data JinjaDialect
+ = DialectGinger2
+ | DialectJinja2
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+-- | One-stop function for parsing and interpreting a template.
+ginger :: forall m. Monad m
+ => TemplateLoader m
+ -- ^ Template loader to use for loading the initial template and
+ -- any included templates. For most use cases, 'fileLoader' should
+ -- be appropriate.
+ -> POptions
+ -- ^ Parser options, determining parser behavior.
+ -> JinjaDialect
+ -- ^ Jinja dialect; currently determines which built-in globals to
+ -- load into the initial namespace.
+ -> Encoder m
+ -- ^ Encoder to use for automatic encoding. Use 'htmlEncoder' for
+ -- HTML templates.
+ -> Text
+ -- ^ Name of the initial template to load. For the 'fileLoader', this
+ -- should be a filename, but for other loaders, it can be whatever
+ -- the loader expects.
+ -> Map Identifier (Value m)
+ -- ^ Variables defined in the initial namespace.
+ -> m (Either RuntimeError Encoded)
+ginger loader parserOptions dialect encoder templateName vars = runExceptT $ do
+ templateSrc <- maybe
+ (throwError $ TemplateFileNotFoundError templateName)
+ pure
+ =<< lift (loader templateName)
+ let parseResult = P.parseGingerWith
+ parserOptions
+ P.template
+ (Text.unpack templateName)
+ templateSrc
+ template <- either
+ (throwError . TemplateParseError templateName . Text.pack)
+ pure
+ parseResult
+ let ctx = defContext
+ { contextEncode = encoder
+ , contextLoadTemplateFile = loader
+ }
+ defVars' = case dialect of
+ DialectGinger2 -> defVars
+ DialectJinja2 -> defVarsCompat
+ env = defEnv
+ { envVars = defVars' <> vars
+ }
+ eitherExceptM $ runGingerT
+ (evalT template >>= encode)
+ ctx
+ env
diff --git a/src/Language/Ginger/AST.hs b/src/Language/Ginger/AST.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/AST.hs
@@ -0,0 +1,693 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Language.Ginger.AST
+where
+
+import Data.Aeson (ToJSON (..), ToJSONKey (..), FromJSON (..), FromJSONKey (..))
+import Data.List (intercalate)
+import Data.Maybe (maybeToList)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.String (IsString (..))
+import Data.Text (Text, pattern (:<) )
+import qualified Data.Text as Text
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Test.Tasty.QuickCheck (Arbitrary (..))
+import qualified Test.Tasty.QuickCheck as QC
+
+import Language.Ginger.SourcePosition
+
+-- | Identifiers are used to represent variable names and object fields.
+newtype Identifier =
+ Identifier { identifierName :: Text }
+ deriving (Show, Eq, Ord, ToJSON, ToJSONKey, FromJSON, FromJSONKey)
+
+instance IsString Identifier where
+ fromString = Identifier . Text.pack
+
+instance Arbitrary Identifier where
+ arbitrary = do
+ x <- QC.oneof $ map pure identifierLeadChars
+ xs <- QC.listOf (QC.oneof $ map pure identifierChars)
+ pure $ Identifier $ Text.pack (x : xs)
+ shrink _ = [] -- shrinking identifiers breaks references
+
+isValidIdentifier :: Text -> Bool
+isValidIdentifier t =
+ case t of
+ Text.Empty -> False
+ c :< _ -> c `elem` identifierLeadChars
+
+identifierLeadChars :: [Char]
+identifierLeadChars =
+ [ 'a' .. 'z' ] ++ ['A' .. 'Z'] ++ ['_']
+
+identifierChars :: [Char]
+identifierChars =
+ identifierLeadChars ++ ['0' .. '9']
+
+-- | Represents an encoded string value, as opposed to a raw (unencoded) string,
+-- which we represent as a plain 'Text'.
+newtype Encoded =
+ Encoded { encoded :: Text }
+ deriving (Show, Eq, Ord, Semigroup, Monoid)
+
+instance Arbitrary Encoded where
+ arbitrary = Encoded . Text.replace "{" "{ " . Text.pack <$> QC.listOf arbitrary
+ shrink (Encoded e) =
+ map (Encoded . Text.pack) . filter (not . null) $ shrink $ Text.unpack e
+
+-- | A template consists of an optional parent template (specified in the
+-- source using the @{% extends %}@ construct), and a body statement.
+data Template =
+ Template
+ { templateParent :: !(Maybe Text)
+ , templateBody :: !Statement
+ }
+ deriving (Show, Eq)
+
+-- | A block represents a section of a template that can be overridden in
+-- derived templates ("template inheritance").
+data Block =
+ Block
+ { blockBody :: !Statement
+ , blockScoped :: !Scoped
+ , blockRequired :: !Required
+ }
+ deriving (Show, Eq)
+
+data SetTarget
+ = SetVar !Identifier
+ | SetMutable !Identifier !Identifier
+ deriving (Show, Eq)
+
+-- | A statement in the template language.
+data Statement
+ = -- | Statement tagged with a source position
+ PositionedS !SourcePosition !Statement
+ | -- | Bare text written in the template, outside of any curly braces
+ ImmediateS !Encoded
+ | -- | An expression interpolation: @{{ expr }}@
+ InterpolationS !Expr
+ | -- | Comment: @{# comment text #}@
+ CommentS !Text
+ | -- | @@@
+ -- {% for keyVar, valueVar in iteree if loopCondition recursive %}
+ -- body
+ -- {% else %}
+ -- body if empty
+ -- {% endfor %}
+ -- @@@
+ ForS
+ !(Maybe Identifier) -- optional loop key variable
+ !Identifier -- loop element variable
+ !Expr -- iteree
+ !(Maybe Expr) -- optional loop condition
+ !Recursivity -- enable recursion?
+ !Statement -- loop body
+ !(Maybe Statement) -- else branch in case iteree is empty
+ | -- | @{% if condition %}yes branch{% else %}no branch{% endif %}@
+ IfS
+ !Expr -- condition
+ !Statement -- true branch
+ !(Maybe Statement) -- false branch
+ | -- | @{% macro name(args) %}body{% endmacro %}@
+ MacroS
+ !Identifier -- macro name
+ ![MacroArg] -- arguments
+ !Statement -- body
+ | -- | @{% call macroName(args) %}body{% endcall %}@
+ CallS
+ !Identifier -- callee
+ ![Expr] -- positional args
+ ![(Identifier, Expr)] -- keyword args
+ !Statement -- body (@caller()@)
+ | -- | @{% filter filterName(args, kwargs) %}body{% endfilter %}@
+ FilterS
+ !Identifier -- name
+ ![Expr] -- positional args
+ ![(Identifier, Expr)] -- keyword args
+ !Statement -- body
+ | -- | @{% set name=expr %}@
+ SetS
+ !SetTarget -- variable name
+ !Expr -- value
+ | -- | @{% set name %}body{% endset %}@
+ SetBlockS
+ !SetTarget -- variable name
+ !Statement -- body
+ !(Maybe Expr) -- optional filter
+ | -- | @{% include includee ignore missing with context %}@
+ IncludeS
+ !Expr
+ !IncludeMissingPolicy
+ !IncludeContextPolicy
+ | -- | @{% import importee as localName item, other_item as other ignore missing with context %}@
+ ImportS
+ !Expr -- filename
+ !(Maybe Identifier) -- local name
+ !(Maybe [(Identifier, Maybe Identifier)]) -- [ (imported name, local name) ]
+ !IncludeMissingPolicy !IncludeContextPolicy
+ | -- | @{% block name with scope required %}body{% endblock %}@
+ BlockS
+ !Identifier -- block name
+ !Block
+ | -- | @{% with defs %}body{% endwith %}@
+ WithS
+ ![(Identifier, Expr)]
+ !Statement
+ | -- | Group of statements; not parsed, but needed for combining statements
+ -- sequentially.
+ GroupS ![Statement]
+ deriving (Show, Eq)
+
+data IncludeMissingPolicy
+ = RequireMissing
+ | IgnoreMissing
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+data IncludeContextPolicy
+ = WithContext
+ | WithoutContext
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+escapeComment :: Statement -> Statement
+escapeComment (CommentS txt) =
+ case Text.splitOn "#}" txt of
+ [] -> GroupS []
+ [x] -> CommentS x
+ xs -> GroupS . intercalate [CommentS "#", CommentS "}"] . map ((:[]) . CommentS) $ xs
+escapeComment x = x
+
+instance Arbitrary Statement where
+ arbitrary = arbitraryStatement mempty
+ shrink (PositionedS pos s) =
+ PositionedS pos <$> shrink s ++
+ [s]
+ shrink (GroupS xs) = map GroupS $ shrink xs
+ shrink (ImmediateS txt) = map ImmediateS $ shrink txt
+ shrink (InterpolationS e) = map InterpolationS $ shrink e
+ shrink (CommentS txt) = map (escapeComment . CommentS . Text.pack) $ shrink $ Text.unpack txt
+ shrink (ForS keyMay val iteree condMay recur body elseBranchMay) =
+ (ForS <$> pure keyMay <*> pure val <*> pure iteree <*> pure condMay <*> pure recur <*> pure body <*> shrink elseBranchMay) ++
+ (ForS <$> pure keyMay <*> pure val <*> pure iteree <*> pure condMay <*> pure recur <*> shrink body <*> pure elseBranchMay) ++
+ (ForS <$> pure keyMay <*> pure val <*> pure iteree <*> pure condMay <*> shrink recur <*> pure body <*> pure elseBranchMay) ++
+ (ForS <$> pure keyMay <*> pure val <*> pure iteree <*> shrink condMay <*> pure recur <*> pure body <*> pure elseBranchMay) ++
+ (ForS <$> pure keyMay <*> pure val <*> shrink iteree <*> pure condMay <*> pure recur <*> pure body <*> pure elseBranchMay) ++
+ [body] ++
+ maybe [] (:[]) elseBranchMay
+ shrink (IfS cond yes noMay) =
+ (IfS <$> shrink cond <*> pure yes <*> pure noMay) ++
+ (IfS <$> pure cond <*> shrink yes <*> pure noMay) ++
+ (IfS <$> pure cond <*> pure yes <*> shrink noMay) ++
+ (pure yes) ++
+ (maybeToList noMay)
+ shrink (MacroS name args body) =
+ (MacroS <$> pure name <*> pure args <*> shrink body) ++
+ (MacroS <$> pure name <*> shrink args <*> pure body) ++
+ (MacroS <$> shrink name <*> shrink args <*> shrink body) ++
+ [body]
+ shrink (CallS name args kwargs body) =
+ (CallS <$> pure name <*> pure args <*> pure kwargs <*> shrink body) ++
+ (CallS <$> pure name <*> pure args <*> shrink kwargs <*> shrink body) ++
+ (CallS <$> pure name <*> shrink args <*> pure kwargs <*> pure body) ++
+ [body]
+ shrink (FilterS name args kwargs body) =
+ (FilterS <$> pure name <*> pure args <*> pure kwargs <*> shrink body) ++
+ (FilterS <$> pure name <*> pure args <*> shrink kwargs <*> shrink body) ++
+ (FilterS <$> pure name <*> shrink args <*> pure kwargs <*> pure body) ++
+ [body]
+ shrink (SetS name expr) =
+ (SetS <$> pure name <*> shrink expr)
+ shrink (SetBlockS name body filterMay) =
+ (SetBlockS <$> pure name <*> pure body <*> shrink filterMay) ++
+ (SetBlockS <$> pure name <*> shrink body <*> pure filterMay)
+ shrink (IncludeS name m c) =
+ (IncludeS <$> pure name <*> pure m <*> shrink c) ++
+ (IncludeS <$> pure name <*> shrink m <*> pure c)
+ shrink (ImportS name lname imports m c) =
+ (ImportS <$> pure name <*> pure lname <*> pure imports <*> pure m <*> shrink c) ++
+ (ImportS <$> pure name <*> pure lname <*> pure imports <*> shrink m <*> pure c) ++
+ (ImportS <$> pure name <*> pure lname <*> shrink imports <*> pure m <*> pure c) ++
+ (ImportS <$> pure name <*> shrink lname <*> pure imports <*> pure m <*> pure c)
+ shrink (BlockS name (Block b s r)) =
+ (BlockS <$> pure name <*> (Block <$> pure b <*> pure s <*> shrink r)) ++
+ (BlockS <$> pure name <*> (Block <$> pure b <*> pure s <*> shrink r)) ++
+ [b]
+ shrink (WithS defs body) =
+ (WithS <$> pure defs <*> shrink body) ++
+ (WithS <$> shrink defs <*> pure body) ++
+ [body]
+
+instance Arbitrary IncludeMissingPolicy where
+ arbitrary = QC.oneof $ map pure [minBound .. maxBound]
+
+instance Arbitrary IncludeContextPolicy where
+ arbitrary = QC.oneof $ map pure [minBound .. maxBound]
+
+arbitraryStatement :: Set Identifier -> QC.Gen Statement
+arbitraryStatement defined = do
+ fuel <- QC.getSize
+ QC.resize (max 0 $ fuel - 1) $
+ QC.oneof
+ [ ImmediateS <$> arbitrary
+ , InterpolationS <$> arbitraryExpr defined
+ , escapeComment . CommentS . Text.strip . Text.pack <$> arbitrary
+
+ , do
+ let fuel' = fuel `div` 6
+ keyNameMaybe <- arbitrary
+ valName <- arbitrary
+ iteree <- QC.resize fuel' $ arbitraryExpr defined
+ let defined' = mempty <> Set.singleton valName <> Set.fromList (maybeToList keyNameMaybe) <> Set.singleton "loop"
+ filterMay <- QC.oneof [ pure Nothing, QC.resize fuel' $ Just <$> arbitraryExpr defined ]
+ body <- QC.resize fuel' $ arbitraryStatement defined'
+ elseBody <- QC.resize fuel' $ QC.oneof [ pure Nothing, Just <$> arbitraryStatement defined' ]
+ recursive <- arbitrary
+
+ pure $ ForS keyNameMaybe valName iteree filterMay recursive body elseBody
+
+ , IfS <$> QC.resize (fuel `div` 3) (arbitraryExpr defined)
+ <*> QC.resize (fuel `div` 3) (arbitraryStatement defined)
+ <*> QC.resize (fuel `div` 3) (QC.oneof [ pure Nothing, Just <$> arbitraryStatement defined ])
+
+ , do
+ args <- QC.resize (fuel `div` 2) $
+ QC.listOf ((,) <$> arbitrary <*> QC.oneof [ pure Nothing, Just <$> arbitraryExpr mempty ])
+ let defined' = Set.fromList (map fst args)
+ body <- QC.resize (fuel `div` 2) (arbitraryStatement defined')
+ name <- arbitrary
+ pure $ MacroS name args body
+ , CallS <$> arbitrary
+ <*> QC.resize (fuel `div` 4) (QC.listOf (arbitraryExpr defined))
+ <*> QC.resize (fuel `div` 4) (QC.listOf ((,) <$> arbitrary <*> arbitraryExpr defined))
+ <*> QC.resize (fuel `div` 2) (arbitraryStatement $ defined <> Set.singleton "caller")
+ , FilterS <$> arbitrary
+ <*> QC.resize (fuel `div` 3) (QC.listOf (arbitraryExpr defined))
+ <*> QC.resize (fuel `div` 3) (QC.listOf ((,) <$> arbitrary <*> arbitraryExpr defined))
+ <*> QC.resize (fuel `div` 3) (arbitraryStatement defined)
+ , SetS <$> QC.frequency
+ [ (100, SetVar <$> arbitrary)
+ , (5, SetMutable <$> arbitrary <*> arbitrary)
+ ]
+ <*> QC.resize (fuel `div` 2) (arbitraryExpr defined)
+ , SetBlockS <$> QC.frequency
+ [ (100, SetVar <$> arbitrary)
+ , (5, SetMutable <$> arbitrary <*> arbitrary)
+ ]
+ <*> QC.resize (fuel `div` 2) (arbitraryStatement defined)
+ <*> QC.resize (fuel `div` 2) (QC.oneof [ pure Nothing, Just <$> arbitraryExpr defined ])
+
+ -- , IncludeS <$> arbitraryExpr defined
+ -- , BlockS <$> arbitrary
+ -- <*> QC.resize (fuel `div` 2) (arbitraryStatement defined)
+ -- <*> arbitrary
+ -- <*> arbitrary
+
+ , do
+ vars <- QC.listOf1 ((,) <$> arbitrary <*> QC.resize (fuel `div` 4) (arbitraryExpr defined))
+ let defined' = mempty <> Set.fromList (map fst vars)
+ body <- QC.resize (fuel * 3 `div` 4) (arbitraryStatement defined')
+ pure $ WithS vars body
+ ]
+
+class Boolish a where
+ is :: a -> Bool
+
+isNot :: Boolish a => a -> Bool
+isNot = not . is
+
+data Scoped = NotScoped | Scoped
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance Boolish Scoped where
+ is = (== Scoped)
+
+data Required = Optional | Required
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance Boolish Required where
+ is = (== Required)
+
+data Recursivity = NotRecursive | Recursive
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance Boolish Recursivity where
+ is = (== Recursive)
+
+instance Arbitrary Scoped where
+ arbitrary = QC.oneof $ map pure [minBound..maxBound]
+
+instance Arbitrary Required where
+ arbitrary = QC.oneof $ map pure [minBound..maxBound]
+
+instance Arbitrary Recursivity where
+ arbitrary = QC.oneof $ map pure [minBound..maxBound]
+
+type MacroArg = (Identifier, Maybe Expr)
+
+-- | An expression. Expressions can occur in interpolations (@{{ ... }}@), and
+-- in various places inside statements.
+data Expr
+ = PositionedE !SourcePosition !Expr
+ | NoneE
+ | BoolE !Bool
+ | StringLitE !Text
+ | IntLitE !Integer
+ | FloatLitE !Double
+ | StatementE !Statement
+ | ListE !(Vector Expr)
+ | DictE ![(Expr, Expr)]
+ -- | @UnaryE op rhs
+ | UnaryE !UnaryOperator !Expr
+ -- | @BinaryE op lhs rhs
+ | BinaryE !BinaryOperator !Expr !Expr
+ -- | @SliceE slicee start length
+ | SliceE !Expr !(Maybe Expr) !(Maybe Expr)
+ -- | @DotE lhs rhs
+ | DotE !Expr !Identifier
+ -- | @IsE scrutinee test args kwargs@
+ | IsE !Expr !Expr ![Expr] ![(Identifier, Expr)]
+ -- | @CallE callee args kwargs@
+ | CallE !Expr ![Expr] ![(Identifier, Expr)]
+ -- | @FilterE arg0 filter args kwargs@
+ | FilterE !Expr !Expr ![Expr] ![(Identifier, Expr)]
+ -- | @TernaryE cond yes no@
+ | TernaryE !Expr !Expr !Expr
+ | VarE !Identifier
+ deriving (Show, Eq)
+
+pattern TrueE :: Expr
+pattern TrueE = BoolE True
+
+pattern FalseE :: Expr
+pattern FalseE = BoolE False
+
+instance Arbitrary Expr where
+ arbitrary = arbitraryExpr mempty
+ shrink (PositionedE pos e) =
+ PositionedE pos <$> shrink e ++
+ [e]
+ shrink (StringLitE txt) = map (StringLitE . Text.pack) $ shrink $ Text.unpack txt
+ shrink (IntLitE i) = IntLitE <$> shrink i
+ shrink (FloatLitE i) = FloatLitE <$> shrink i
+ shrink (StatementE s) = StatementE <$> shrink s
+ shrink (ListE v) =
+ case V.uncons v of
+ Nothing -> pure NoneE
+ Just (x, xs) | V.null xs ->
+ (ListE . V.singleton <$> shrink x) ++ [x]
+ _ ->
+ ListE . V.fromList <$> shrink (V.toList v)
+ shrink (DictE xs) = DictE <$> shrink xs
+ shrink (UnaryE op e) =
+ (UnaryE <$> pure op <*> shrink e) ++
+ [e]
+ shrink (DotE a b) =
+ (DotE <$> pure a <*> shrink b) ++
+ (DotE <$> shrink a <*> pure b) ++
+ [a]
+ shrink (BinaryE op a b) =
+ (BinaryE <$> pure op <*> shrink a <*> pure b) ++
+ (BinaryE <$> pure op <*> pure a <*> shrink b) ++
+ [a, b]
+ shrink (SliceE slicee startMay endMay) =
+ (SliceE <$> pure slicee <*> pure startMay <*> shrink endMay) ++
+ (SliceE <$> pure slicee <*> shrink startMay <*> pure endMay) ++
+ (SliceE <$> shrink slicee <*> pure startMay <*> pure endMay) ++
+ maybeToList startMay ++
+ maybeToList endMay ++
+ [slicee]
+ shrink (IsE a b args kwargs) =
+ (IsE <$> pure a <*> pure b <*> pure args <*> shrink kwargs) ++
+ (IsE <$> pure a <*> pure b <*> shrink args <*> pure kwargs) ++
+ (IsE <$> pure a <*> shrink b <*> pure args <*> pure kwargs) ++
+ (IsE <$> shrink a <*> pure b <*> pure args <*> pure kwargs) ++
+ [a, b] ++ args ++ map snd kwargs
+ shrink (CallE f args kwargs) =
+ (CallE <$> pure f <*> pure args <*> shrink kwargs) ++
+ (CallE <$> pure f <*> shrink args <*> pure kwargs) ++
+ (CallE <$> shrink f <*> pure args <*> pure kwargs) ++
+ [f] ++ args ++ map snd kwargs
+ shrink (FilterE a f args kwargs) =
+ (FilterE <$> pure a <*> pure f <*> pure args <*> shrink kwargs) ++
+ (FilterE <$> pure a <*> pure f <*> shrink args <*> pure kwargs) ++
+ (FilterE <$> pure a <*> shrink f <*> pure args <*> pure kwargs) ++
+ (FilterE <$> shrink a <*> pure f <*> pure args <*> pure kwargs) ++
+ [a, f] ++ args ++ map snd kwargs
+ shrink (TernaryE a b c) =
+ (TernaryE <$> pure a <*> pure b <*> shrink c) ++
+ (TernaryE <$> pure a <*> shrink b <*> pure c) ++
+ (TernaryE <$> shrink a <*> pure b <*> pure c) ++
+ [a, b, c]
+ shrink _ = []
+
+arbitraryExpr :: Set Identifier -> QC.Gen Expr
+arbitraryExpr defined = do
+ fuel <- QC.getSize
+ if fuel <= 1 then
+ pure NoneE
+ else do
+ let baseOptions =
+ [ (10, pure NoneE)
+ , (100, BoolE <$> arbitrary)
+ , (100, StringLitE <$> QC.resize (fuel - 1) (Text.pack <$> QC.listOf arbitrary))
+ , (100, IntLitE <$> QC.resize (fuel - 1) arbitrary)
+ , (100, FloatLitE <$> QC.resize (fuel - 1) arbitrary)
+ , (100, ListE . V.fromList <$> fuelledList (arbitraryExpr defined))
+ , (100, DictE <$> fuelledList ((,) <$> arbitraryExpr defined <*> arbitraryExpr defined))
+ , (90, QC.resize (max 0 $ fuel `div` 2 - 1) $
+ BinaryE <$> arbitrary
+ <*> arbitraryExpr defined
+ <*> arbitraryExpr defined
+ )
+
+ , (10, QC.resize (max 0 $ fuel `div` 2 - 1) $
+ SliceE <$> arbitraryExpr defined
+ <*> (fmap IntLitE <$> arbitrary)
+ <*> (fmap IntLitE <$> arbitrary)
+ )
+ , (10, QC.resize (max 0 $ fuel `div` 2 - 1) $
+ DotE <$> arbitraryExpr defined
+ <*> arbitrary
+ )
+
+ , (100, QC.resize (fuel `div` 3) $
+ CallE <$> arbitraryExpr defined
+ <*> fuelledList (arbitraryExpr defined)
+ <*> fuelledList ((,) <$> arbitrary <*> arbitraryExpr defined)
+ )
+
+ , (100, QC.resize (fuel `div` 3) $
+ TernaryE <$> arbitraryExpr defined
+ <*> arbitraryExpr defined
+ <*> arbitraryExpr defined
+ )
+
+ , (10, QC.resize (fuel - 1) $
+ VarE <$> arbitrary
+ )
+ ]
+ extraOptions =
+ if Set.null defined then
+ []
+ else
+ [ (100, VarE <$> QC.oneof (map pure $ Set.toList defined))
+ ]
+ options = baseOptions <> extraOptions
+ QC.frequency options
+
+data UnaryOperator
+ = UnopNot
+ | UnopNegate
+ deriving (Show, Eq, Enum, Ord, Bounded)
+
+pattern NotE :: Expr -> Expr
+pattern NotE a = UnaryE UnopNot a
+
+pattern NegateE :: Expr -> Expr
+pattern NegateE a = UnaryE UnopNegate a
+
+data BinaryOperator
+ -- Math
+ = BinopPlus
+ | BinopMinus
+ | BinopDiv
+ | BinopIntDiv
+ | BinopMod
+ | BinopMul
+ | BinopPower
+ -- Comparison
+ | BinopEqual
+ | BinopNotEqual
+ | BinopGT
+ | BinopGTE
+ | BinopLT
+ | BinopLTE
+ -- Boolean
+ | BinopAnd
+ | BinopOr
+
+ -- List / dict membership
+ | BinopIn
+ -- List / dict indexing (@[]@)
+ | BinopIndex
+ -- String concatenation
+ | BinopConcat
+ -- Test
+ deriving (Show, Eq, Enum, Ord, Bounded)
+
+pattern PlusE :: Expr -> Expr -> Expr
+pattern PlusE a b = BinaryE BinopPlus a b
+
+pattern MinusE :: Expr -> Expr -> Expr
+pattern MinusE a b = BinaryE BinopMinus a b
+
+pattern DivE :: Expr -> Expr -> Expr
+pattern DivE a b = BinaryE BinopDiv a b
+
+pattern IntDivE :: Expr -> Expr -> Expr
+pattern IntDivE a b = BinaryE BinopIntDiv a b
+
+pattern ModE :: Expr -> Expr -> Expr
+pattern ModE a b = BinaryE BinopMod a b
+
+pattern MulE :: Expr -> Expr -> Expr
+pattern MulE a b = BinaryE BinopMul a b
+
+pattern PowerE :: Expr -> Expr -> Expr
+pattern PowerE a b = BinaryE BinopPower a b
+
+pattern EqualE :: Expr -> Expr -> Expr
+pattern EqualE a b = BinaryE BinopEqual a b
+
+pattern NotEqualE :: Expr -> Expr -> Expr
+pattern NotEqualE a b = BinaryE BinopNotEqual a b
+
+pattern GT_E :: Expr -> Expr -> Expr
+pattern GT_E a b = BinaryE BinopGT a b
+
+pattern GTE_E :: Expr -> Expr -> Expr
+pattern GTE_E a b = BinaryE BinopGTE a b
+
+pattern LT_E :: Expr -> Expr -> Expr
+pattern LT_E a b = BinaryE BinopLT a b
+
+pattern LTE_E :: Expr -> Expr -> Expr
+pattern LTE_E a b = BinaryE BinopLTE a b
+
+pattern AndE :: Expr -> Expr -> Expr
+pattern AndE a b = BinaryE BinopAnd a b
+
+pattern OrE :: Expr -> Expr -> Expr
+pattern OrE a b = BinaryE BinopOr a b
+
+pattern InE :: Expr -> Expr -> Expr
+pattern InE a b = BinaryE BinopIn a b
+
+pattern IndexE :: Expr -> Expr -> Expr
+pattern IndexE a b = BinaryE BinopIndex a b
+
+pattern ConcatE :: Expr -> Expr -> Expr
+pattern ConcatE a b = BinaryE BinopConcat a b
+
+instance Arbitrary BinaryOperator where
+ arbitrary = QC.oneof (map pure [minBound .. maxBound])
+
+fuelledList :: QC.Gen a -> QC.Gen [a]
+fuelledList subGen = do
+ fuel <- QC.getSize
+ if fuel < 1 then
+ pure []
+ else do
+ s <- QC.chooseInt (1, fuel)
+ x <- QC.resize s subGen
+ xs <- QC.resize (max 0 $ fuel - s - 10) (fuelledList subGen)
+ pure $ x : xs
+
+
+traverseS :: (Statement -> Statement) -> (Expr -> Expr) -> Statement -> Statement
+traverseS fS fE stmt = go (fS stmt)
+ where
+ go (PositionedS pos s) = PositionedS pos $ traverseS fS fE s
+ go (GroupS xs) = GroupS (map (traverseS fS fE) xs)
+ go (InterpolationS e) = InterpolationS (traverseE fE fS e)
+ go (ForS k v i condMay rec body elseMay) =
+ ForS
+ k v
+ (traverseE fE fS i)
+ (traverseE fE fS <$> condMay)
+ rec
+ (traverseS fS fE body)
+ (traverseS fS fE <$> elseMay)
+ go (IfS cond yes noMay) =
+ IfS (traverseE fE fS cond) (traverseS fS fE yes) (traverseS fS fE <$> noMay)
+ go (MacroS name args body) =
+ MacroS name [(n, traverseE fE fS <$> d) | (n, d) <- args] (traverseS fS fE body)
+ go (CallS name args kwargs body) =
+ CallS
+ name
+ (traverseE fE fS <$> args)
+ [(n, traverseE fE fS v) | (n, v) <- kwargs]
+ (traverseS fS fE body)
+ go (FilterS name args kwargs body) =
+ FilterS
+ name
+ (traverseE fE fS <$> args)
+ [(n, traverseE fE fS v) | (n, v) <- kwargs]
+ (traverseS fS fE body)
+ go (SetS name val) =
+ SetS name (traverseE fE fS val)
+ go (SetBlockS name body filterMay) =
+ SetBlockS name (traverseS fS fE body) (traverseE fE fS <$> filterMay)
+ go (IncludeS includee mp cp) =
+ IncludeS (traverseE fE fS includee) mp cp
+ go (ImportS importee lname imports mp cp) =
+ ImportS (traverseE fE fS importee) lname imports mp cp
+ go (BlockS name (Block body s r)) =
+ BlockS name (Block (traverseS fS fE body) s r)
+ go (WithS defs body) =
+ WithS [ (n, traverseE fE fS e) | (n, e) <- defs ] (traverseS fS fE body)
+ go s = s
+
+traverseE :: (Expr -> Expr) -> (Statement -> Statement) -> Expr -> Expr
+traverseE fE fS expr = go (fE expr)
+ where
+ go (StatementE s) = StatementE (traverseS fS fE s)
+ go (ListE xs) = ListE (fmap (traverseE fE fS) xs)
+ go (DictE items) =
+ DictE [ (traverseE fE fS k, traverseE fE fS v) | (k, v) <- items ]
+ go (UnaryE op e) = UnaryE op (traverseE fE fS e)
+ go (BinaryE op a b) = BinaryE op (traverseE fE fS a) (traverseE fE fS b)
+ go (SliceE slicee startMay lengthMay) =
+ SliceE
+ (traverseE fE fS slicee)
+ (traverseE fE fS <$> startMay)
+ (traverseE fE fS <$> lengthMay)
+ go (DotE e i) = DotE (traverseE fE fS e) i
+ go (IsE scrutinee test args kwargs) =
+ IsE
+ (traverseE fE fS scrutinee)
+ (traverseE fE fS test)
+ (traverseE fE fS <$> args)
+ [ (n, traverseE fE fS e) | (n, e) <- kwargs ]
+ go (CallE callee args kwargs) =
+ CallE
+ (traverseE fE fS callee)
+ (traverseE fE fS <$> args)
+ [ (n, traverseE fE fS e) | (n, e) <- kwargs ]
+ go (FilterE arg0 f args kwargs) =
+ FilterE
+ (traverseE fE fS arg0)
+ (traverseE fE fS f)
+ (traverseE fE fS <$> args)
+ [ (n, traverseE fE fS e) | (n, e) <- kwargs ]
+ go (TernaryE cond yes no) =
+ TernaryE
+ (traverseE fE fS cond)
+ (traverseE fE fS yes)
+ (traverseE fE fS no)
+ go e = e
diff --git a/src/Language/Ginger/FileLoader.hs b/src/Language/Ginger/FileLoader.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/FileLoader.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.Ginger.FileLoader
+where
+
+import System.FilePath
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Maybe (fromMaybe)
+
+import Language.Ginger.Value
+
+fileLoader :: forall m. MonadIO m
+ => FilePath
+ -> TemplateLoader m
+fileLoader baseDir templateName = do
+ let templateBasename =
+ Text.unpack .
+ Text.replace ".." "" .
+ Text.replace "//" "/" .
+ fromMaybe templateName .
+ Text.stripPrefix "/" $
+ templateName
+ templateFilename =
+ baseDir templateBasename
+ liftIO $ Just <$> Text.readFile templateFilename
diff --git a/src/Language/Ginger/Interpret.hs b/src/Language/Ginger/Interpret.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Interpret.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Language.Ginger.Interpret
+( Eval (..)
+, EvalState (..)
+, evalE
+, evalS
+, evalSs
+, evalT
+, GingerT (..)
+, runGingerT
+, defEnv
+, defContext
+, setVar
+, lookupVar
+, lookupVarMaybe
+, stringify
+, scoped
+ ,bind
+, valuesEqual
+, RuntimeError (..)
+)
+where
+
+import Language.Ginger.Interpret.Type
+import Language.Ginger.Interpret.DefEnv
+import Language.Ginger.Interpret.Eval
+import Language.Ginger.RuntimeError
diff --git a/src/Language/Ginger/Interpret/Builtins.hs b/src/Language/Ginger/Interpret/Builtins.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Interpret/Builtins.hs
@@ -0,0 +1,2612 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Language.Ginger.Interpret.Builtins
+where
+
+import Language.Ginger.AST
+import Language.Ginger.Interpret.Type
+import Language.Ginger.RuntimeError
+import Language.Ginger.Value
+import Language.Ginger.Render (renderSyntaxText)
+
+import Control.Monad.Except
+import Control.Monad.Trans (lift)
+import qualified Data.Aeson as JSON
+import qualified Data.Array as Array
+import Data.Bits (popCount)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.Char (isUpper, isLower, isAlphaNum, isPrint, isSpace, isAlpha, isDigit, ord)
+import Data.Foldable (asum)
+import Data.List (sortBy)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe, listToMaybe, catMaybes, isJust)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Time
+ ( TimeZone (..)
+ , ZonedTime (..)
+ , TimeOfDay (..)
+ , LocalTime (..)
+ , parseTimeM
+ , defaultTimeLocale
+ , utc
+ , fromGregorian
+ , utcToZonedTime
+ , zonedTimeToUTC
+ , formatTime
+ )
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Text.Printf (printf)
+import Text.Read (readMaybe)
+import qualified Text.Regex.TDFA as RE
+
+--------------------------------------------------------------------------------
+-- Builtins
+--------------------------------------------------------------------------------
+
+type BuiltinAttribs a m = Map Identifier (a -> m (Either RuntimeError (Value m)))
+
+builtinGlobals :: forall m. Monad m
+ => (Expr -> GingerT m (Value m))
+ -> Map Identifier (Value m)
+builtinGlobals evalE = Map.fromList $
+ [ ("abs", numericBuiltin
+ "builtin:abs"
+ (Just ProcedureDoc
+ { procedureDocName = "abs"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "number")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "number")
+ , procedureDocDescription = "Absolute of a number."
+ }
+ )
+ abs abs)
+ , ("attr", fnToValue "builtin:attr"
+ (Just ProcedureDoc
+ { procedureDocName = "attr"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "dict")
+ Nothing
+ ""
+ , ArgumentDoc
+ "attrName"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocAny)
+ , procedureDocDescription = Text.unlines
+ [ "Get a named attribute from a `dict` or dict-like object."
+ , "Unlike `[]` or dot member access, this will only look " <>
+ "at attributes, not items."
+ ]
+ }
+ )
+ $ \x y -> case y :: Value m of
+ StringV yStr ->
+ fmap (fromMaybe NoneV) <$> getAttrRaw @m x (Identifier yStr)
+ _ ->
+ pure . Right $ NoneV)
+ , ("batch", ProcedureV fnBatch)
+ , ("capitalize", textBuiltin
+ "builtin:capitalize"
+ (Just ProcedureDoc
+ { procedureDocName = "capitalize"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to title case."
+ }
+ )
+ Text.toTitle)
+ , ("center", ProcedureV fnCenter)
+ , ("count", ProcedureV fnLength)
+ , ("date", ProcedureV fnDateFormat)
+ , ("dictsort", ProcedureV fnDictsort)
+ , ("e", ProcedureV fnEscape)
+ , ("escape", ProcedureV fnEscape)
+ , ("even", intBuiltin
+ "builtin:even"
+ (Just ProcedureDoc
+ { procedureDocName = "even"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "int")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocDescription = "Check if `value` is an even number"
+ }
+ )
+ even)
+ , ("filesizeformat", ProcedureV fnFilesizeFormat)
+ , ("first", ProcedureV fnFirst)
+ , ("float", ProcedureV fnToFloat)
+ -- , ("forceescape", undefined)
+ -- , ("format", undefined)
+ -- , ("groupby", undefined)
+ -- , ("indent", undefined)
+ , ("int", ProcedureV fnToInt)
+ , ("items", ProcedureV fnItems)
+ , ("join", ProcedureV fnJoin)
+ , ("json", ProcedureV fnToJSON)
+ , ("last", ProcedureV fnLast)
+ , ("length", ProcedureV fnLength)
+ , ("list", ProcedureV fnToList)
+ , ("lower", textBuiltin
+ "builtin:lower"
+ (Just ProcedureDoc
+ { procedureDocName = "lower"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to lowercase."
+ }
+ )
+ Text.toLower)
+ , ("map", FilterV $ fnMap evalE)
+ -- , ("max", undefined)
+ -- , ("min", undefined)
+ , ("namespace", ProcedureV NamespaceProcedure)
+ , ("odd", intBuiltin
+ "builtin:odd"
+ (Just ProcedureDoc
+ { procedureDocName = "odd"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "int")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocDescription = "Checks if `value` is an odd number."
+ }
+ )
+ odd)
+ -- , ("pprint", undefined)
+ -- , ("random", undefined)
+ -- , ("rejectattr", undefined)
+ -- , ("reject", undefined)
+ , ("replace", ProcedureV fnStrReplace)
+ , ("reverse", ProcedureV fnReverse)
+ , ("round", ProcedureV fnRound)
+ , ("safe", textBuiltin
+ "builtin:safe"
+ (Just ProcedureDoc
+ { procedureDocName = "safe"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "encoded")
+ , procedureDocDescription = "Mark `value` as pre-encoded HTML."
+ }
+ )
+ (EncodedV @m . Encoded)
+
+ )
+ -- , ("selectattr", undefined)
+ , ("select", FilterV $ fnSelect evalE)
+ -- , ("slice", undefined)
+ , ("sort", ProcedureV fnSort)
+ , ("split", ProcedureV fnStrSplit)
+ , ("string", ProcedureV fnToString)
+ -- , ("striptags", undefined)
+ -- , ("sum", undefined)
+ , ("title", textBuiltin
+ "builtin:title"
+ (Just ProcedureDoc
+ { procedureDocName = "title"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to title case."
+ }
+ )
+ Text.toTitle)
+ , ("tojson", ProcedureV fnToJSON)
+ -- , ("trim", undefined)
+ -- , ("truncate", undefined)
+ -- , ("unique", undefined)
+ , ("upper", textBuiltin
+ "builtin:upper"
+ (Just ProcedureDoc
+ { procedureDocName = "upper"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to uppercase."
+ }
+ )
+ Text.toUpper)
+ -- , ("urlencode", undefined)
+ -- , ("urlize", undefined)
+ , ("wordcount", textBuiltin
+ "builtin:wordcount"
+ (Just ProcedureDoc
+ { procedureDocName = "wordcount"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "string")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "int")
+ , procedureDocDescription = "Counts words in value."
+ }
+ )
+ (length . Text.words))
+ -- , ("wordwrap", undefined)
+ -- , ("xmlattr", undefined)
+ ]
+
+builtinGlobalsNonJinja :: forall m. Monad m
+ => (Expr -> GingerT m (Value m))
+ -> Map Identifier (Value m)
+builtinGlobalsNonJinja _evalE = Map.fromList $
+ [ ("strip", ProcedureV fnStrStrip)
+ , ("regex", regexModule)
+ , ("dateformat", ProcedureV fnDateFormat)
+ , ("help", ProcedureV fnHelp)
+ ]
+
+builtinIntAttribs :: forall m. Monad m => BuiltinAttribs Integer m
+builtinIntAttribs = Map.fromList
+ [ ("denominator", intProp (const (1 :: Integer)))
+ , ("bit_count", intAttrib
+ "builtin:int:bit_count"
+ (Just ProcedureDoc
+ { procedureDocName = "int.bit_count"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "int")
+ , procedureDocDescription =
+ Text.unlines
+ [ "Bit count (popcount)."
+ , "Counts the number of set bits in an integer."
+ ]
+ }
+ )
+ popCount)
+ -- , ("bit_length", ?)
+ -- , ("conjugate", ?)
+ -- , ("from_bytes", ?)
+ -- , ("to_bytes", ?)
+ , ("imag", intProp (const (0 :: Integer)))
+ , ("numerator", intProp id)
+ , ("real", intProp id)
+ ]
+
+builtinFloatAttribs :: Monad m => BuiltinAttribs Double m
+builtinFloatAttribs = Map.fromList
+ [ ("imag", floatProp (const (0 :: Double)))
+ , ("real", floatProp id)
+ -- , ("is_integer", ?)
+ -- , ("hex", ?)
+ -- , ("as_integer_ratio", ?)
+ -- , ("conjugate", ?)
+ ]
+
+builtinBoolAttribs :: Monad m => BuiltinAttribs Bool m
+builtinBoolAttribs = Map.fromList
+ [ ("denominator", boolProp (const (1 :: Integer)))
+ , ("bit_count", boolAttrib
+ "builtin:bool:bit_count"
+ (Just ProcedureDoc
+ { procedureDocName = "bool.bit_count"
+ , procedureDocReturnType = (Just $ TypeDocSingle "int")
+ , procedureDocArgs = mempty
+ , procedureDocDescription =
+ Text.unlines
+ [ "Bit count (popcount)."
+ , "Counts the number of set bits."
+ , "Since a boolean only has one bit, this will " <>
+ "always be either 0 or 1."
+ ]
+ }
+ )
+ popCount)
+ -- , ("bit_length", ?)
+ -- , ("conjugate", ?)
+ -- , ("from_bytes", ?)
+ , ("to_bytes", boolProp (BS.singleton . fromIntegral . fromEnum))
+ , ("imag", boolProp (const (0 :: Integer)))
+ , ("numerator", boolProp fromEnum)
+ , ("real", boolProp fromEnum)
+ ]
+
+builtinStringAttribs :: forall m. Monad m => BuiltinAttribs Text m
+builtinStringAttribs = Map.fromList
+ [ ("length", textProp Text.length)
+ , ("capitalize", textAttrib
+ "builtin:string:capitalize"
+ (Just ProcedureDoc
+ { procedureDocName = "string.capitalize"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to title case."
+ }
+ )
+ Text.toTitle)
+ , ("casefold", textAttrib
+ "builtin:string:casefold"
+ (Just ProcedureDoc
+ { procedureDocName = "string.casefold"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription =
+ "Convert `value` to canonical case for " <>
+ "case-insensitive comparison"
+ }
+ )
+ Text.toCaseFold)
+ , ("center", textProcAttrib fnCenter)
+ , ("count", textProcAttrib fnStrCount)
+ , ("encode", textProcAttrib fnStrEncode)
+ , ("endswith", textProcAttrib fnStrEndswith)
+ -- , ("expandtabs", ?)
+ -- , ("find", ?)
+ -- , ("format", ?)
+ -- , ("format_map", ?)
+ -- , ("index", ?)
+ , ("isalnum", textAttrib
+ "builtin:string:isalnum"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isalnum"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocDescription = "Check whether a string is alpha-numeric (a letter or a digit)."
+ }
+ )
+ (Text.all isAlphaNum)
+ )
+ , ("isalpha", textAttrib
+ "builtin:string:isalpha"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isalpha"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string is alphabetic (consists solely of letters)."
+ }
+ )
+ (Text.all isAlpha))
+ , ("isascii", textAttrib
+ "builtin:string:isascii"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isascii"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string consists solely of 7-bit ASCII characters."
+ }
+ )
+ (Text.all ((< 128) . ord)))
+ , ("isdecimal", textAttrib
+ "builtin:string:isdecimal"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isdecimal"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string is a decimal number"
+ }
+ )
+ isDecimal)
+ , ("isdigit", textAttrib
+ "builtin:string:isdigit"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isdigit"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string consists solely of digits."
+ }
+ )
+ (Text.all isDigit))
+ -- , ("isidentifier", ?)
+ , ("islower", textNProcAttrib
+ "builtin:string:islower"
+ (Just ProcedureDoc
+ { procedureDocName = "string.islower"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string is all-lowercase"
+ }
+ )
+ isLowerVal)
+ -- , ("isnumeric", ?)
+ , ("isprintable", textAttrib
+ "builtin:string:isprintable"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isprintable"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string contains only printable characters."
+ }
+ )
+ (Text.all isPrint))
+ , ("isspace", textAttrib
+ "builtin:string:isspace"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isspace"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string contains only whitespace."
+ }
+ )
+ (Text.all isSpace))
+ , ("isupper", textNProcAttrib
+ "builtin:string:isupper"
+ (Just ProcedureDoc
+ { procedureDocName = "string.isupper"
+ , procedureDocReturnType = (Just $ TypeDocSingle "bool")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Check whether a string is all-uppercase."
+ }
+ )
+ isUpperVal)
+ , ("join", textProcAttrib fnStrJoin)
+ -- , ("ljust", ?)
+ , ("lower", textAttrib
+ "builtin:lower"
+ (Just ProcedureDoc
+ { procedureDocName = "string.lower"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to lowercase."
+ }
+ )
+ Text.toLower)
+ , ("lstrip", textProcAttrib fnStrLStrip)
+ -- , ("maketrans", ?)
+ -- , ("partition", ?)
+ -- , ("removeprefix", ?)
+ -- , ("removesuffix", ?)
+ , ("replace", textProcAttrib fnStrReplace)
+ -- , ("rfind", ?)
+ -- , ("rindex", ?)
+ -- , ("rjust", ?)
+ -- , ("rpartition", ?)
+ , ("rstrip", textProcAttrib fnStrRStrip)
+ , ("split", textProcAttrib fnStrSplit)
+ , ("splitlines", textAttrib
+ "builtin:string:splitlines()"
+ (Just ProcedureDoc
+ { procedureDocName = "string.splitlines"
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocArgs = mempty
+ , procedureDocDescription = "Split a string into lines."
+ }
+ )
+ Text.lines)
+ , ("startswith", textProcAttrib fnStrStartswith)
+ , ("strip", textProcAttrib fnStrStrip)
+ -- , ("swapcase", ?)
+ , ("title", textAttrib
+ "builtin:title"
+ (Just ProcedureDoc
+ { procedureDocName = "string.title"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to title case."
+ }
+ )
+ Text.toTitle)
+ -- , ("translate", ?)
+ , ("upper", textAttrib
+ "builtin:upper"
+ (Just ProcedureDoc
+ { procedureDocName = "string.upper"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = (Just $ TypeDocSingle "string")
+ , procedureDocDescription = "Convert `value` to uppercase."
+ }
+ )
+ Text.toUpper)
+ -- , ("zfill", ?)
+ ]
+
+builtinListAttribs :: Monad m => BuiltinAttribs (Vector (Value m)) m
+builtinListAttribs = Map.fromList
+ [
+ ]
+
+builtinDictAttribs :: Monad m => BuiltinAttribs (Map Scalar (Value m)) m
+builtinDictAttribs = Map.fromList
+ [
+ ]
+
+--------------------------------------------------------------------------------
+-- Built-in function implementations
+--------------------------------------------------------------------------------
+
+regexModule :: forall m. Monad m => Value m
+regexModule = dictV
+ [ ("match", ProcedureV fnReMatch)
+ , ("matches", ProcedureV fnReMatches)
+ , ("test", ProcedureV fnReTest)
+ ]
+
+runReWith :: forall a m. Monad m
+ => (RE.Regex -> Text -> a)
+ -> Text
+ -> Text
+ -> Text
+ -> ExceptT RuntimeError m a
+runReWith matchFunc regexText haystack optsText = do
+ let opts = parseCompOpts optsText
+ let regex = RE.makeRegexOpts opts RE.defaultExecOpt (Text.unpack regexText)
+ pure $ matchFunc regex haystack
+
+fnReMatch :: forall m. Monad m => Procedure m
+fnReMatch = mkFn3 "regex.match"
+ (Text.unlines
+ [ "Match a regular expression against a string."
+ , "Returns an array where the first element is the entire " <>
+ "match, and subsequent elements are matches on " <>
+ "subexpressions (capture groups)."
+ ]
+ )
+ ( "regex"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "haystack"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "opts"
+ , Just ""
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ runReWith (\r h -> convertMatchOnceText $ RE.matchOnceText r h)
+
+fnReMatches :: forall m. Monad m => Procedure m
+fnReMatches = mkFn3 "regex.match"
+ (Text.unlines
+ [ "Match a regular expression against a string."
+ , "Returns an array of matches, where each match is an " <>
+ "array where the first element is the entire match, and " <>
+ "subsequent elements are matches on subexpressions " <>
+ "(capture groups)."
+ ]
+ )
+ ( "regex"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "haystack"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "opts"
+ , Just ""
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ runReWith (\r h -> fmap convertMatchText $ RE.matchAllText r h)
+
+fnReTest :: forall m. Monad m => Procedure m
+fnReTest = mkFn3 "regex.test"
+ (Text.unlines
+ [ "Match a regular expression against a string."
+ , "Returns true if at least one match exists, false otherwise."
+ ]
+ )
+ ( "regex"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "haystack"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "opts"
+ , Just ""
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "bool")
+ $ runReWith (\r h -> isJust $ RE.matchOnceText r h)
+
+parseCompOpts :: Text -> RE.CompOption
+parseCompOpts = do
+ Text.foldl'
+ (\x ->
+ \case
+ 'i' -> x { RE.caseSensitive = False }
+ 'm' -> x { RE.multiline = True }
+ _ -> x
+ )
+ RE.blankCompOpt
+
+convertMatchOnceText :: Maybe (Text, RE.MatchText Text, Text) -> Maybe [Text]
+convertMatchOnceText Nothing = Nothing
+convertMatchOnceText (Just (_, m, _)) = Just (convertMatchText m)
+
+convertMatchText :: RE.MatchText Text -> [Text]
+convertMatchText matches =
+ map fst $ Array.elems matches
+
+fnLength :: forall m. Monad m => Procedure m
+fnLength = mkFn1 "length"
+ (Text.unlines
+ [ "Get the length of a string, list, or dictionary."
+ ]
+ )
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAlternatives [ "string", "list", "dict" ]
+ , ""
+ )
+ (Just $ TypeDocSingle "int")
+ $ \case
+ StringV s -> pure $ Text.length s
+ ListV xs -> pure $ length xs
+ DictV xs -> pure $ Map.size xs
+ x ->
+ throwError $
+ ArgumentError
+ "length"
+ "value"
+ "iterable"
+ (tagNameOf x)
+
+fnEscape :: forall m. Monad m => Procedure m
+fnEscape = mkFn1' "escape"
+ (Text.unlines
+ [ "Escape the argument."
+ ]
+ )
+ ( "value"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "encoded")
+ $ \ctx value ->
+ (EncodedV @m) <$>
+ encodeWith ctx value
+
+fnToList :: forall m. Monad m => Procedure m
+fnToList = mkFn1 "list"
+ (Text.unlines
+ [ "Convert `value` to a list, if possible"
+ ]
+ )
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ \case
+ ListV xs ->
+ pure xs
+ DictV xs ->
+ pure (V.fromList $ Map.elems xs)
+ StringV txt ->
+ pure $ fmap (toValue . Text.singleton) . V.fromList $ Text.unpack txt
+ EncodedV (Encoded txt) ->
+ pure $ fmap (toValue . Text.singleton) . V.fromList $ Text.unpack txt
+ NativeV obj ->
+ native (Right <$> nativeObjectAsList obj) >>=
+ maybe
+ (throwError $
+ ArgumentError
+ "list"
+ "value"
+ "iterable"
+ "non-iterable native object"
+ )
+ pure
+ BytesV bytes ->
+ pure $ fmap toValue . V.fromList $ BS.unpack bytes
+ x -> throwError $
+ ArgumentError
+ "list"
+ "value"
+ "iterable"
+ (tagNameOf x)
+
+
+fnToFloat :: forall m. Monad m => Procedure m
+fnToFloat = mkFn2 "float"
+ (Text.unlines
+ [ "Convert `value` to float."
+ , "If `default` is given, values that cannot be converted " <>
+ " to floats will be replaced with this default value."
+ ]
+ )
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "default"
+ , Just 0
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "float")
+ $ \value def ->
+ case value of
+ IntV i -> pure $ fromIntegral i
+ BoolV b -> pure $ fromIntegral $ fromEnum b
+ FloatV f -> pure f
+ NoneV -> pure 0
+ StringV s ->
+ pure . fromMaybe def $ readMaybe (Text.unpack s)
+ _ -> pure def
+
+fnToInt :: forall m. Monad m => Procedure m
+fnToInt = mkFn3 "int"
+ (Text.unlines
+ [ "Convert `value` to int."
+ , "If `default` is given, values that cannot be converted " <>
+ " to integers will be replaced with this default value."
+ ]
+ )
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "default"
+ , Just 0
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "base"
+ , Just 10 :: Maybe Integer
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "int")
+ $ \value def _base ->
+ case value of
+ IntV i -> pure i
+ BoolV b -> pure $ fromIntegral $ fromEnum b
+ FloatV f -> pure $ round f
+ NoneV -> pure 0
+ StringV s ->
+ pure . fromMaybe def $ readMaybe (Text.unpack s)
+ _ -> pure def
+
+fnToString :: forall m. Monad m => Procedure m
+fnToString = mkFn1 "string"
+ "Convert argument to string"
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value ->
+ stringify value
+
+fnReverse :: forall m. Monad m => Procedure m
+fnReverse = mkFn1 "reverse"
+ "Reverse a list or string"
+ ( "value"
+ , Nothing
+ , Just $ TypeDocAlternatives [ "list", "string" ]
+ , ""
+ )
+ (Just $ TypeDocAlternatives [ "list", "string" ])
+ $ \case
+ Left t -> pure $ StringV (Text.reverse t)
+ Right xs -> pure $ ListV (V.reverse (xs :: Vector (Value m)))
+
+fnItems :: forall m. Monad m => Procedure m
+fnItems = mkFn1 "items"
+ "Convert a dict to a list of its elements without the keys."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "dict"
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ \value ->
+ pure (Map.toAscList value :: [(Scalar, Value m)])
+
+data DictSortBy
+ = ByKey
+ | ByValue
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance ToValue DictSortBy m where
+ toValue ByKey = StringV "key"
+ toValue ByValue = StringV "value"
+
+instance (Monad m) => FromValue DictSortBy m where
+ fromValue (StringV "key") = pure . Right $ ByKey
+ fromValue (StringV "value") = pure . Right $ ByValue
+ fromValue (StringV x) = pure . Left $ TagError "conversion to dictsort target" "'key' or 'value'" ("string " <> Text.show x)
+ fromValue x = pure . Left $ TagError "conversion to dictsort target" "string" (tagNameOf x)
+
+fnSort :: forall m. Monad m => Procedure m
+fnSort = mkFn4 "sort"
+ ""
+ ( "value"
+ , Nothing :: Maybe [Value m]
+ , Just $ TypeDocSingle "list"
+ , ""
+ )
+ ( "reverse"
+ , Just False
+ , Just $ TypeDocSingle "bool"
+ , ""
+ )
+ ( "case_sensitive"
+ , Just False
+ , Just $ TypeDocSingle "bool"
+ , ""
+ )
+ ( "attribute"
+ , Just Nothing :: Maybe (Maybe (Value m))
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ \value reverseSort caseSensitive attributeMay -> do
+ let cmp a b = if caseSensitive then
+ compare (fst a) (fst b)
+ else
+ compare (Text.toCaseFold (fst a)) (Text.toCaseFold (fst b))
+ cmp' = if reverseSort then flip cmp else cmp
+ proj x = do
+ sk <- case attributeMay of
+ Nothing ->
+ stringify x
+ Just a -> do
+ v <- fmap (fromMaybe NoneV) $ eitherExceptM $ getItemOrAttrRaw x a
+ stringify v
+ pure (sk, x)
+ (items' :: [(Text, Value m)]) <- mapM proj value
+ pure $ map snd $ sortBy cmp' items'
+
+
+
+fnDictsort :: forall m. Monad m => Procedure m
+fnDictsort = mkFn4 "dictsort"
+ "Sort a dict, returning a list of key-value pairs."
+ ( "value"
+ , Nothing :: Maybe (Map Scalar (Value m))
+ , Just $ TypeDocSingle "dict"
+ , ""
+ )
+ ( "case_sensitive"
+ , Just False
+ , Just $ TypeDocSingle "bool"
+ , ""
+ )
+ ( "by"
+ , Just ByKey
+ , Just $ TypeDocSingle "string"
+ , "One of 'key', 'value'"
+ )
+ ( "reverse"
+ , Just False
+ , Just $ TypeDocSingle "bool"
+ , ""
+ )
+ (Just $ TypeDocSingle "list")
+ $ \value caseSensitive by reverseSort -> do
+ let cmp a b = if caseSensitive then
+ compare (fst a) (fst b)
+ else
+ compare (Text.toCaseFold (fst a)) (Text.toCaseFold (fst b))
+ cmp' = if reverseSort then flip cmp else cmp
+ proj (k, v) = do
+ sk <- case by of
+ ByKey ->
+ case k of
+ StringScalar s -> pure s
+ IntScalar i -> pure $ Text.show i
+ FloatScalar f -> pure $ Text.show f
+ NoneScalar -> pure ""
+ BoolScalar b -> pure . Text.toLower $ Text.show b
+ EncodedScalar (Encoded e) -> pure e
+ BytesScalar bs -> pure $ Text.decodeUtf8 bs
+ ByValue ->
+ stringify v
+ pure (sk, (k, v))
+ itemsRaw = Map.toList value
+ items' <- mapM proj itemsRaw
+ pure $ map snd $ sortBy cmp' items'
+
+fnSelect :: forall m. Monad m
+ => (Expr -> GingerT m (Value m))
+ -> Filter m
+fnSelect evalE =
+ NativeFilter
+ (Just ProcedureDoc
+ { procedureDocName = "select"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "value"
+ (Just $ TypeDocSingle "list")
+ Nothing
+ ""
+ , ArgumentDoc
+ "filter"
+ (Just $ TypeDocAlternatives [ "string", "filter", "test", "procedure" ])
+ (Just "none")
+ ( "A filter or test to apply to each element to determine " <>
+ "whether to select it or not."
+ )
+ , ArgumentDoc
+ "attribute"
+ (Just $ TypeDocAlternatives [ "string", "none" ])
+ (Just "none")
+ ( "If specified, the name of an attribute to extract from each " <>
+ "element for testing.\n" <>
+ "This argument can only be passed by keyword, not positionally."
+ )
+ ]
+ , procedureDocReturnType = (Just $ TypeDocSingle "list")
+ , procedureDocDescription = Text.unlines
+ [ "Select by a test or filter, and/or an attribute."
+ ]
+ }
+ ) $
+ \scrutineeE args ctx env -> runExceptT $ do
+ -- This one is quite a monster, because it accepts arguments in so many
+ -- different ways.
+ -- Specifically:
+ --
+ -- @scrutinee|select('foobar', args...)@ - interpret the string
+ -- @'foobar'@ as the name of a filter (or procedure), and pass @args...@
+ -- on to that filter.
+ --
+ -- @scrutinee|select(foobar, args...)@ - interpret @foobar@ as a filter
+ -- (or a procedure), and pass @args...@ on to that filter.
+ --
+ -- @scrutinee|select(attribute='foobar', {default=value})@ - interpret
+ -- @'foobar' as the name of an attribute in each list element, extract
+ -- that list element, use the @default=@ value if the attribute is
+ -- absent.
+ let funcName = "select"
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ []
+ args
+ varargs <- fnArg funcName "varargs" argValues
+ (kwargs :: Map Scalar (Value m)) <- fnArg funcName "kwargs" argValues
+ (scrutinee :: Value m) <- eitherExceptM $ runGingerT (evalE scrutineeE) ctx env
+ (xs :: Vector (Value m)) <- eitherExceptM $ fromValue scrutinee
+
+ case varargs of
+ [] ->
+ -- No argument = error.
+ throwError $
+ ArgumentError
+ funcName
+ "attribute/callee"
+ "attribute=identifier or callable"
+ "no argument"
+ (test:varargs') -> do
+ -- Re-pack the remaining arguments
+ let args' = zip (repeat Nothing) varargs' ++
+ Map.toList (Map.mapKeys toIdentifier kwargs)
+
+ -- Determine how to handle each list element.
+ let apply' testV x =
+ case testV of
+ StringV name -> do
+ -- If it's a string, we interpret it as a filter name, and
+ -- try to look up the corresponding filter in the current
+ -- scope.
+ testV' <- eitherExceptM $
+ runGingerT
+ (withJinjaTests $ evalE (VarE $ Identifier name))
+ ctx env
+ apply' testV' x
+ DictV m -> do
+ -- If it's a dict, try to find a @"__call__"@ item.
+ case Map.lookup "__call__" m of
+ Nothing -> throwError $
+ NonCallableObjectError
+ (tagNameOf test <> " " <> Text.show testV)
+ Just v -> apply' v x
+ NativeV obj -> do
+ -- If it's a native object, use its @nativeObjectCall@
+ -- method, if available.
+ case nativeObjectCall obj of
+ Nothing -> throwError $
+ NonCallableObjectError
+ "non-callable native object"
+ Just f -> eitherExceptM (f obj args') >>=
+ eitherExcept . asBoolVal
+ TestV f -> do
+ -- If it's a test, we apply it as such, mapping the
+ -- current list element to the variable "@" (which cannot
+ -- be used as a normal identifier, because the syntax
+ -- doesn't allow it). We need to bind it, because
+ -- 'runFilter' takes an unevaluated expression as its
+ -- scrutinee argument, but we have an already-evaluated
+ -- value.
+ let env' = env { envVars = Map.insert "@" x $ envVars env }
+ eitherExceptM $ runTest f (VarE "@") args' ctx env'
+ ProcedureV (NativeProcedure _ _ f) -> do
+ -- If it's a native procedure, we can just call it without
+ -- binding anything.
+ eitherExceptM (f ((Nothing, x):args') ctx) >>=
+ eitherExcept . asBoolVal
+ ProcedureV (GingerProcedure env' argSpecs body) -> do
+ -- If it's a ginger procedure, we need to prepend the
+ -- current list element to the argument list (so it becomes
+ -- the first positional argument), and then resolve and
+ -- bind all the arguments into the environment where we
+ -- then run the ginger procedure.
+ args'' <- eitherExcept $
+ resolveArgs
+ "select callback"
+ argSpecs
+ ((Nothing, x):args')
+ eitherExceptM (runGingerT (setVars args'' >> evalE body) ctx env') >>=
+ eitherExcept . asBoolVal
+ _ ->
+ -- Not something we can call.
+ throwError $
+ NonCallableObjectError
+ (tagNameOf test <> " " <> Text.show testV)
+
+ apply = apply' test
+
+ ListV <$> V.filterM apply xs
+ where
+ toIdentifier :: Scalar -> Maybe Identifier
+ toIdentifier (StringScalar s) = Just $ Identifier s
+ toIdentifier (IntScalar i) = Just $ Identifier (Text.show i)
+ toIdentifier (FloatScalar f) = Just $ Identifier (Text.show f) -- dubious
+ toIdentifier _ = Nothing
+
+fnMap :: forall m. Monad m
+ => (Expr -> GingerT m (Value m))
+ -> Filter m
+fnMap evalE =
+ NativeFilter
+ (Just ProcedureDoc
+ { procedureDocName = "builtins:map"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = Just $ TypeDocSingle "list"
+ , procedureDocDescription = Text.unlines
+ [ "Map a filter or procedure over a list."
+ ]
+ }
+ ) $
+ \scrutineeE args ctx env -> runExceptT $ do
+ -- This one is quite a monster, because it accepts arguments in so many
+ -- different ways.
+ -- Specifically:
+ --
+ -- @scrutinee|map('foobar', args...)@ - interpret the string @'foobar'@ as
+ -- the name of a filter (or procedure), and pass @args...@ on to that filter.
+ --
+ -- @scrutinee|map(foobar, args...)@ - interpret @foobar@ as a filter (or a
+ -- procedure), and pass @args...@ on to that filter.
+ --
+ -- @scrutinee|map(attribute='foobar', {default=value})@ - interpret @'foobar'
+ -- as the name of an attribute in each list element, extract that list
+ -- element, use the @default=@ value if the attribute is absent.
+ let funcName = "map"
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ []
+ args
+ varargs <- fnArg funcName "varargs" argValues
+ (kwargs :: Map Scalar (Value m)) <- fnArg funcName "kwargs" argValues
+ (scrutinee :: Value m) <- eitherExceptM $ runGingerT (evalE scrutineeE) ctx env
+ (xs :: Vector (Value m)) <- eitherExceptM $ fromValue scrutinee
+
+ -- First, let's see if an attribute was specified.
+ let attributeMay = Map.lookup "attribute" kwargs
+ case attributeMay of
+ Just attribute -> do
+ -- Attribute was specified, so let's extract that.
+ -- We also need to find the default value.
+ let defVal = fromMaybe NoneV (Map.lookup "default" kwargs) :: Value m
+ ListV <$> V.mapM
+ (\x -> do
+ attributeIdent <- Identifier <$> eitherExceptM (fromValue attribute)
+ fromMaybe defVal <$>
+ eitherExceptM
+ (getAttrOrItemRaw x attributeIdent)
+ )
+ xs
+ Nothing ->
+ -- Attribute was not specified, so we will use the first of the
+ -- positional arguments as a mapping function/filter.
+ case varargs of
+ [] ->
+ -- No argument = error.
+ throwError $
+ ArgumentError
+ funcName
+ "attribute/callee"
+ "attribute=identifier or callable"
+ "no argument"
+ (callee:varargs') -> do
+ -- Re-pack the remaining arguments
+ let args' = zip (repeat Nothing) varargs' ++
+ Map.toList (Map.mapKeys toIdentifier kwargs)
+
+ -- Determine how to handle each list element.
+ let apply' filterV x =
+ case filterV of
+ StringV name -> do
+ -- If it's a string, we interpret it as a filter name, and
+ -- try to look up the corresponding filter in the current
+ -- scope.
+ filterV' <- eitherExceptM $
+ runGingerT
+ (withJinjaFilters $ evalE (VarE $ Identifier name))
+ ctx env
+ apply' filterV' x
+ DictV m -> do
+ -- If it's a dict, try to find a @"__call__"@ item.
+ case Map.lookup "__call__" m of
+ Nothing -> throwError $
+ NonCallableObjectError
+ (tagNameOf callee <> " " <> Text.show filterV)
+ Just v -> apply' v x
+ NativeV obj -> do
+ -- If it's a native object, use its @nativeObjectCall@
+ -- method, if available.
+ case nativeObjectCall obj of
+ Nothing -> throwError $
+ NonCallableObjectError
+ "non-callable native object"
+ Just f -> eitherExceptM $ f obj args'
+ FilterV f -> do
+ -- If it's a filter, we apply it as such, mapping the
+ -- current list element to the variable "@" (which cannot
+ -- be used as a normal identifier, because the syntax
+ -- doesn't allow it). We need to bind it, because
+ -- 'runFilter' takes an unevaluated expression as its
+ -- scrutinee argument, but we have an already-evaluated
+ -- value.
+ let env' = env { envVars = Map.insert "@" x $ envVars env }
+ eitherExceptM $ runFilter f (VarE "@") args' ctx env'
+ ProcedureV (NativeProcedure _ _ f) -> do
+ -- If it's a native procedure, we can just call it without
+ -- binding anything.
+ eitherExceptM $ f ((Nothing, x):args') ctx
+ ProcedureV (GingerProcedure env' argSpecs body) -> do
+ -- If it's a ginger procedure, we need to prepend the
+ -- current list element to the argument list (so it becomes
+ -- the first positional argument), and then resolve and
+ -- bind all the arguments into the environment where we
+ -- then run the ginger procedure.
+ args'' <- eitherExcept $
+ resolveArgs
+ "map callback"
+ argSpecs
+ ((Nothing, x):args')
+ eitherExceptM $
+ runGingerT (setVars args'' >> evalE body) ctx env'
+ _ ->
+ -- Not something we can call.
+ throwError $
+ NonCallableObjectError
+ (tagNameOf callee <> " " <> Text.show filterV)
+
+ apply = apply' callee
+
+ ListV <$> mapM apply xs
+ where
+ toIdentifier :: Scalar -> Maybe Identifier
+ toIdentifier (StringScalar s) = Just $ Identifier s
+ toIdentifier (IntScalar i) = Just $ Identifier (Text.show i)
+ toIdentifier (FloatScalar f) = Just $ Identifier (Text.show f) -- dubious
+ toIdentifier _ = Nothing
+
+fnRound :: forall m. Monad m => Procedure m
+fnRound = mkFn3 "round"
+ "Round a floating-point value."
+ ( "value"
+ , Nothing :: Maybe Double
+ , Just $ TypeDocSingle "float"
+ , ""
+ )
+ ( "precision"
+ , Just 0 :: Maybe Integer
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ ( "method"
+ , Just "common"
+ , Just $ TypeDocSingle "string"
+ , "One of 'common', 'ceil', 'floor'."
+ )
+ (Just $ TypeDocAlternatives ["int", "float"])
+ $ \value precision method -> do
+ (r :: Double -> Integer) <- case method of
+ "common" -> pure (floor . (+ 0.5))
+ "ceil" -> pure ceiling
+ "floor" -> pure floor
+ x -> throwError $ ArgumentError "round" "method" "one of 'common', 'floor', 'ceil'" x
+ if precision == 0 then
+ pure $ fromIntegral $ r value
+ else do
+ let factor :: Double = 10 ** (fromIntegral precision)
+ pure $ fromIntegral (r (value * factor) :: Integer) / factor
+
+fnStrReplace :: Monad m => Procedure m
+fnStrReplace = mkFn4 "replace"
+ "String search-and-replace."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "old"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , "String to search for"
+ )
+ ( "new"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , "Replacement"
+ )
+ ( "count"
+ , Just (Nothing :: Maybe Int)
+ , Just $ TypeDocAny
+ , "Maximum number of replacements."
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value old new countMay -> do
+ let parts = Text.splitOn old value
+ case countMay of
+ Nothing -> pure $ Text.intercalate new parts
+ Just 0 -> pure value
+ Just count | count < length parts ->
+ pure $
+ Text.intercalate new (take count parts) <>
+ new <>
+ Text.intercalate old (drop count parts)
+ Just _ -> pure $ Text.intercalate new parts
+
+
+fnStrStrip :: Monad m => Procedure m
+fnStrStrip = mkFn2 "strip"
+ "Strip whitespace or selected characters from both ends of a string."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "chars"
+ , Just Nothing
+ , Just $ TypeDocSingle "string"
+ , "If specified: characters to strip."
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value charsMay -> do
+ case charsMay of
+ Nothing -> pure $ Text.strip value
+ Just charsText -> do
+ let chars = Text.unpack charsText
+ pure $
+ Text.dropWhile (`elem` chars) .
+ Text.dropWhileEnd (`elem` chars) $
+ value
+
+fnStrLStrip :: Monad m => Procedure m
+fnStrLStrip = mkFn2 "lstrip"
+ "Strip whitespace or selected characters from the beginning of a string."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "chars"
+ , Just Nothing
+ , Just $ TypeDocAny
+ , "If specified: characters to strip."
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value charsMay -> do
+ case charsMay of
+ Nothing -> pure $ Text.stripStart value
+ Just charsText -> do
+ let chars = Text.unpack charsText
+ pure $ Text.dropWhile (`elem` chars) value
+
+fnStrRStrip :: Monad m => Procedure m
+fnStrRStrip = mkFn2 "rstrip"
+ "Strip whitespace or selected characters from the end of a string."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "chars"
+ , Just Nothing
+ , Just $ TypeDocAny
+ , "If specified: characters to strip."
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value charsMay -> do
+ case charsMay of
+ Nothing -> pure $ Text.stripEnd value
+ Just charsText -> do
+ let chars = Text.unpack charsText
+ pure $ Text.dropWhileEnd (`elem` chars) value
+
+fnToJSON :: forall m. Monad m => Procedure m
+fnToJSON = mkFn2 "tojson"
+ "Convert `value` to JSON"
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "indent"
+ , Just (Nothing :: Maybe Int)
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value _indentMay ->
+ pure . Text.decodeUtf8 . LBS.toStrict $ JSON.encode value
+
+fnJoin :: forall m. Monad m => Procedure m
+fnJoin = mkFn3 "join"
+ "Join an iterable into a string"
+ ( "iterable"
+ , Nothing :: Maybe [Value m]
+ , Just $ TypeDocSingle "list"
+ , ""
+ )
+ ( "d"
+ , Just "" :: Maybe Text
+ , Just $ TypeDocSingle "string"
+ , "Default value to use to replace empty elements"
+ )
+ ( "attr"
+ , Just Nothing :: Maybe (Maybe Text)
+ , Just $ TypeDocAny
+ , "If given, an attribute to pick from each element"
+ )
+ (Just $ TypeDocSingle "string")
+ $ \iterable d attrMay -> do
+ iterable' <- case attrMay of
+ Nothing -> pure iterable
+ Just attr ->
+ catMaybes <$>
+ mapM
+ (\x -> eitherExceptM $ getAttrOrItemRaw x (Identifier attr))
+ iterable
+ Text.intercalate d <$> mapM (eitherExcept . asTextVal) iterable'
+
+fnStrJoin :: Monad m => Procedure m
+fnStrJoin = mkFn2 "join"
+ ("`str.join(iterable)` joins `iterable` into a string, using " <>
+ "`str` as a separator."
+ )
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "iterable"
+ , Just []
+ , Just $ TypeDocSingle "list"
+ , ""
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value iterable -> do
+ pure $ Text.intercalate value iterable
+
+fnStrSplit :: Monad m => Procedure m
+fnStrSplit = mkFn3 "split"
+ "Split a string by a separator."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "sep"
+ , Just Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "maxsplit"
+ , Just Nothing
+ , Just $ TypeDocSingle "int"
+ , "Maximum number of splits. Unlimited if not specified."
+ )
+ (Just $ TypeDocSingle "list")
+ $ \value sepMay maxsplitMay -> do
+ items <- case sepMay of
+ Nothing -> pure . Text.words . Text.strip $ value
+ Just "" -> throwError $
+ ArgumentError
+ "split"
+ "sep"
+ "non-empty string"
+ "empty string"
+ Just sep -> pure $ Text.splitOn sep value
+ case maxsplitMay of
+ Nothing ->
+ pure items
+ Just maxsplit ->
+ pure $ take maxsplit items ++ [Text.unwords $ drop maxsplit items]
+
+fnStrStartswith :: Monad m => Procedure m
+fnStrStartswith = mkFn4 "startswith"
+ "Check whether a string starts with a given prefix."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "prefix"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "start"
+ , Just 0
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ ( "end"
+ , Just Nothing
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ (Just $ TypeDocSingle "bool")
+ $ \value prefix start endMay -> do
+ let value' = case endMay of
+ Nothing -> Text.drop start value
+ Just end -> Text.drop start . Text.take end $ value
+ pure $ prefix `Text.isPrefixOf` value'
+
+fnStrEndswith :: Monad m => Procedure m
+fnStrEndswith = mkFn4 "endswith"
+ "Check whether a string ends with a given suffix."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "suffix"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "start"
+ , Just 0
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ ( "end"
+ , Just Nothing
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ (Just $ TypeDocSingle "bool")
+ $ \value suffix start endMay -> do
+ let value' = case endMay of
+ Nothing -> Text.drop start value
+ Just end -> Text.drop start . Text.take end $ value
+ pure $ suffix `Text.isSuffixOf` value'
+
+fnStrEncode :: Monad m => Procedure m
+fnStrEncode = mkFn3 "encode"
+ "Encode string into the selected encoding."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "encoding"
+ , Just "utf-8"
+ , Just $ TypeDocSingle "string"
+ , "Encoding. One of 'ascii', 'utf8' (default), 'utf16le', 'utf16be', 'utf32le', 'utf32be'"
+ )
+ ( "errors"
+ , Just ("strict" :: Text)
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "encoded")
+ $ \value encoding _errors -> do
+ func <- case Text.filter isAlphaNum . Text.toCaseFold $ encoding of
+ "ascii" -> pure encodeASCII
+ "utf8" -> pure Text.encodeUtf8
+ "utf16le" -> pure Text.encodeUtf16LE
+ "utf16be" -> pure Text.encodeUtf16BE
+ "utf32le" -> pure Text.encodeUtf32LE
+ "utf32be" -> pure Text.encodeUtf32BE
+ _ -> throwError $ ArgumentError "encode" "encoding" "valid encoding" encoding
+ pure $ func value
+ where
+ encodeASCII =
+ BS.pack .
+ map fromIntegral .
+ filter (<= 127) .
+ map ord .
+ Text.unpack
+
+fnStrCount :: Monad m => Procedure m
+fnStrCount = mkFn4 "count"
+ "Count the number of occurrences of a substring."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "sub"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , "Substring to search for"
+ )
+ ( "start"
+ , Just 0
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ ( "end"
+ , Just Nothing
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ (Just $ TypeDocSingle "int")
+ $ \value sub start endMay -> do
+ let value' = case endMay of
+ Nothing -> Text.drop start value
+ Just end -> Text.drop start . Text.take end $ value
+ pure $ Text.count sub value'
+
+fnCenter :: Monad m => Procedure m
+fnCenter = mkFn3 "center"
+ "Pad string on both sides to center it in the given space"
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "width"
+ , Just 80
+ , Just $ TypeDocSingle "int"
+ , ""
+ )
+ ( "fillchar"
+ , Just " "
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ (Just $ TypeDocSingle "string")
+ $ \value width fillchar' -> do
+ let fillchar = Text.take 1 . (<> " ") $ fillchar'
+ let paddingTotal = max 0 $ fromInteger width - Text.length value
+ paddingLeft = paddingTotal `div` 2
+ paddingRight = paddingTotal - paddingLeft
+ pure $
+ Text.replicate paddingLeft fillchar <>
+ value <>
+ Text.replicate paddingRight fillchar
+
+newtype FileSize = FileSize Integer
+
+instance ToValue FileSize m where
+ toValue (FileSize i) = IntV i
+
+instance Monad m => FromValue FileSize m where
+ fromValue (IntV i) =
+ pure . Right $ FileSize i
+ fromValue (FloatV f) =
+ pure . Right $ FileSize (round f)
+ fromValue (StringV txt) =
+ case readMaybe (Text.unpack txt) of
+ Nothing ->
+ case readMaybe (Text.unpack txt) of
+ Nothing ->
+ pure . Left $ ArgumentError "int" "value" "numeric value" (Text.show txt)
+ Just (f :: Double) ->
+ pure . Right $ FileSize (round f)
+ Just i ->
+ pure . Right $ FileSize i
+ fromValue x =
+ pure . Left $ ArgumentError "int" "value" "numeric value" (tagNameOf x)
+
+fnFilesizeFormat :: Monad m => Procedure m
+fnFilesizeFormat = mkFn2 "filesizeformat"
+ "Format `value` as a human-readable file size."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocSingle "number"
+ , ""
+ )
+ ( "binary"
+ , Just False
+ , Just $ TypeDocSingle "bool"
+ , "If set, use binary units (kiB, MiB, ...) instead of decimal (kB, MB, ...)"
+ )
+ (Just $ TypeDocSingle "string")
+ $ \(FileSize value) binary -> do
+ let (multiplier, units) =
+ if binary then
+ (1024, ["ki", "Mi", "Gi", "Ti", "Pi"])
+ else
+ (1000, ["k", "M", "G", "T", "P"])
+ let str = go multiplier units value
+ pure $ str <> "B"
+ where
+ go :: Integer -> [Text] -> Integer -> Text
+ go _ [] value
+ = Text.show value
+ go multiplier units value | value < 0
+ = "-" <> go multiplier units (abs value)
+ go multiplier (unit:units) value
+ | value < multiplier
+ = Text.show value
+ | value < multiplier * multiplier || null units
+ = Text.pack $
+ printf "%i.%01i%s"
+ (value `div` multiplier)
+ ((value * 10 `div` multiplier) `mod` 10)
+ unit
+ | otherwise
+ = go multiplier units (value `div` multiplier)
+
+fnBatch :: forall m. Monad m => Procedure m
+fnBatch = mkFn3 "batch"
+ "Split up a list into chunks of length `linecount`."
+ ( "value"
+ , Nothing
+ , Just $ TypeDocAny
+ , ""
+ )
+ ( "linecount"
+ , Nothing
+ , Just $ TypeDocSingle "int"
+ , "Number of items per chunk. Unlimited if not specified."
+ )
+ ( "fill_with"
+ , Just Nothing
+ , Just $ TypeDocAny
+ , "Filler to pad shorter chunks with. If not specified, don't pad."
+ )
+ (Just $ TypeDocSingle "list")
+ $ \value linecount fillWithMay -> do
+ pure $ chunksOf fillWithMay linecount value
+ where
+ chunksOf :: Maybe (Value m) -> Int -> [Value m] -> [[Value m]]
+ chunksOf _ _ [] = []
+ chunksOf fillMay n xs =
+ case take n xs of
+ xs' | length xs' < n ->
+ let paddingLength = n - length xs'
+ padding = case (fillMay, paddingLength) of
+ (Just fill, p) | p > 0 ->
+ replicate paddingLength fill
+ _ -> []
+ in [xs' ++ padding]
+ xs' -> xs' : chunksOf fillMay n (drop n xs)
+
+fnFirst :: forall m. Monad m => Procedure m
+fnFirst = mkFn1 "first"
+ "Get the first element from a list, or the first character from a string."
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAlternatives [ "list", "string", "bytes" ]
+ , ""
+ )
+ (Just $ TypeDocAny)
+ $ \case
+ ListV v -> case V.uncons v of
+ Just (x, _) -> pure x
+ Nothing -> pure NoneV
+ StringV txt -> pure $ StringV $ Text.take 1 txt
+ EncodedV (Encoded txt) -> pure $ EncodedV . Encoded $ Text.take 1 txt
+ BytesV arr -> pure . toValue $ BS.indexMaybe arr 0
+ x -> throwError $ ArgumentError "first" "value" "list or string" (tagNameOf x)
+
+fnLast :: forall m. Monad m => Procedure m
+fnLast = mkFn1 "last"
+ "Get the last element from a list, or the last character from a string."
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAlternatives [ "list", "string", "bytes" ]
+ , ""
+ )
+ (Just $ TypeDocAny)
+ $ \case
+ ListV v -> case V.unsnoc v of
+ Just (_, x) -> pure x
+ Nothing -> pure NoneV
+ StringV txt -> pure $ StringV $ Text.takeEnd 1 txt
+ BytesV arr -> pure . toValue $ BS.indexMaybe arr (BS.length arr - 1)
+ EncodedV (Encoded txt) -> pure $ EncodedV . Encoded $ Text.takeEnd 1 txt
+ x -> throwError $ ArgumentError "first" "value" "list or string" (tagNameOf x)
+
+autoParseDate :: TimeZone -> Text -> Maybe ZonedTime
+autoParseDate defTZ input =
+ asum [ parse t (Text.unpack input) | (parse, t) <- formats ]
+ where
+ ztparse :: String -> String -> Maybe ZonedTime
+ ztparse fmt = parseTimeM True defaultTimeLocale fmt
+ utcparse :: String -> String -> Maybe ZonedTime
+ utcparse fmt i = do
+ lt <- parseTimeM True defaultTimeLocale fmt i
+ return $ ZonedTime lt defTZ
+ formats =
+ [ (ztparse, "%Y-%m-%dT%H:%M:%S%Q%Z")
+ , (utcparse, "%Y-%m-%d %H:%M:%S%Q")
+ , (ztparse, "%Y-%m-%d %H:%M:%S%Q%z")
+ , (ztparse, "%Y-%m-%d %H:%M:%S%Q%Z")
+ , (utcparse, "%Y-%m-%d")
+ ]
+
+dateFromParts :: forall m. Monad m
+ => TimeZone
+ -> [Value m]
+ -> Maybe ZonedTime
+dateFromParts defTZ parts = do
+ year <- case parts of
+ (IntV y : _) -> Just y
+ (StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _) -> Nothing
+ _ -> Just 2000
+ month <- case parts of
+ (_ : IntV m : _) -> Just m
+ (_ : StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _ : _) -> Nothing
+ _ -> Just 1
+ day <- case parts of
+ (_ : _ : IntV d : _) -> Just d
+ (_ : _ : StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _ : _ : _) -> Nothing
+ _ -> Just 1
+ hour <- case parts of
+ (_ : _ : _ : IntV h : _) -> Just h
+ (_ : _ : _ : StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _ : _ : _ : _) -> Nothing
+ _ -> Just 0
+ minute <- case parts of
+ (_ : _ : _ : _ : IntV m : _) -> Just m
+ (_ : _ : _ : _ : StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _ : _ : _ : _ : _) -> Nothing
+ _ -> Just 0
+ second <- case parts of
+ (_ : _ : _ : _ : _ : IntV s : _) -> Just s
+ (_ : _ : _ : _ : _ : StringV x : _) -> readMaybe . Text.unpack $ x
+ (_ : _ : _ : _ : _ : _ : _) -> Nothing
+ _ -> Just 0
+ tz <- case parts of
+ (_ : _ : _ : _ : _ : _ : v : _) -> parseTZ v
+ _ -> Just defTZ
+ pure $ ZonedTime
+ (LocalTime
+ (fromGregorian year (fromInteger month) (fromInteger day))
+ (TimeOfDay (fromInteger hour) (fromInteger minute) (fromInteger second)))
+ tz
+
+parseTZ :: Value m -> Maybe TimeZone
+parseTZ (StringV s) =
+ parseTimeM True defaultTimeLocale "%z" $ Text.unpack s
+parseTZ (IntV i) =
+ Just $ TimeZone (fromInteger i) False ""
+parseTZ (ListV v) =
+ case V.toList v of
+ [IntV minutes, BoolV summerOnly, StringV name] ->
+ Just $ TimeZone (fromInteger minutes) summerOnly (Text.unpack name)
+ _ -> Nothing
+parseTZ _ = Nothing
+
+convertTZ :: Maybe TimeZone -> ZonedTime -> ZonedTime
+convertTZ Nothing = id
+convertTZ (Just tz) = utcToZonedTime tz . zonedTimeToUTC
+
+fnDateFormat :: forall m. Monad m => Procedure m
+fnDateFormat = mkFn4 "dateformat"
+ (Text.unlines
+ [ "Format a date/time value."
+ , "Format strings follow the specification found here: " <>
+ "[Date.Time.Format.formatTime](https://hackage.haskell.org/package/time-1.14/docs/Data-Time-Format.html#v:formatTime)"
+ , "Accepted input formats:"
+ , "- `%Y-%m-%dT%H:%M:%S%Q%Z`"
+ , "- `%Y-%m-%d %H:%M:%S%Q`"
+ , "- `%Y-%m-%d %H:%M:%S%Q%z`"
+ , "- `%Y-%m-%d %H:%M:%S%Q%Z`"
+ , "- `%Y-%m-%d`"
+ ]
+ )
+ ( "date"
+ , Nothing :: Maybe (Either Text [Value m])
+ , Just $ TypeDocAlternatives [ "string", "list" ]
+ , "May be given as a formatted date, or as a list " <>
+ "of `[ year, month, day, hours, minutes, seconds, " <>
+ "timezone ]`. " <>
+ "Partial lists will be padded with appropriate defaults."
+ )
+ ( "format"
+ , Just "%c"
+ , Just $ TypeDocSingle "string"
+ , ""
+ )
+ ( "tz"
+ , Just Nothing :: Maybe (Maybe (Value m))
+ , Just $ TypeDocAlternatives [ "string", "int", "list" ]
+ , "Time zone. May be given as a string specifying an offset " <>
+ "(±HHMM), an integer offset in minutes, or a list " <>
+ "containing 3 elements: offset in minues (int), " <>
+ "summer-only (bool), and timezone name (string)."
+ )
+ ( "locale"
+ , Just Nothing :: Maybe (Maybe Text)
+ , Just $ TypeDocAny
+ , "Select a locale. Not yet implemented, ignored."
+ )
+ (Just $ TypeDocSingle "string")
+ $ \dateRaw fmt tzVal _localeMay -> do
+ let tzMay = parseTZ =<< tzVal
+ defTZ = fromMaybe utc tzMay
+ locale = defaultTimeLocale -- TODO: use getlocale
+ date <- maybe
+ (throwError $
+ ArgumentError
+ "dateformat"
+ "date"
+ "date string or date array"
+ (Text.show dateRaw)
+ )
+ pure $
+ case dateRaw of
+ Left str -> autoParseDate defTZ str
+ Right parts -> dateFromParts defTZ parts
+ pure . Text.pack . formatTime locale (Text.unpack fmt) . convertTZ tzMay $ date
+
+fnHelp :: forall m. Monad m => Procedure m
+fnHelp = mkFn1 "help"
+ "Get documentation for the given value, if available."
+ ( "value"
+ , Nothing :: Maybe (Value m)
+ , Just $ TypeDocAny
+ , ""
+ )
+ (Just $ TypeDocSingle "dict")
+ $ \value -> do
+ case value of
+ ProcedureV (NativeProcedure _ doc _) ->
+ pure (toValue doc :: Value m)
+ _ ->
+ pure NoneV
+
+isUpperVal :: Value m -> Value m
+isUpperVal (StringV txt) = BoolV (Text.all isUpper txt)
+isUpperVal (EncodedV (Encoded txt)) = BoolV (Text.all isUpper txt)
+isUpperVal _ = FalseV
+
+isLowerVal :: Value m -> Value m
+isLowerVal (StringV txt) = BoolV (Text.all isLower txt)
+isLowerVal (EncodedV (Encoded txt)) = BoolV (Text.all isLower txt)
+isLowerVal _ = FalseV
+
+isBoolean :: Bool -> Value m -> Value m
+isBoolean b1 (BoolV b2) = BoolV (b1 == b2)
+isBoolean _ _ = FalseV
+
+isNone :: Value m -> Value m
+isNone NoneV = TrueV
+isNone _ = FalseV
+
+isDecimal :: Text -> Bool
+isDecimal "" = False
+isDecimal t = case Text.splitOn "." t of
+ ["0"] ->
+ True
+ [intpart] ->
+ not (Text.null intpart) &&
+ Text.all isDigit intpart &&
+ not ("0" `Text.isPrefixOf` intpart)
+ ["0", fracpart] ->
+ Text.all isDigit fracpart
+ [intpart, fracpart] ->
+ not (Text.null intpart && Text.null fracpart) &&
+ Text.all isDigit intpart &&
+ not ("0" `Text.isPrefixOf` intpart) &&
+ Text.all isDigit fracpart
+ _ -> False
+
+--------------------------------------------------------------------------------
+-- Text conversion
+--------------------------------------------------------------------------------
+
+
+--------------------------------------------------------------------------------
+-- Utilities
+--------------------------------------------------------------------------------
+
+allEitherBool :: [(Either a Bool)] -> Either a Bool
+allEitherBool [] = Right True
+allEitherBool (Right True : xs) = allEitherBool xs
+allEitherBool (x : _) = x
+
+--------------------------------------------------------------------------------
+-- Attribute and item helpers
+--------------------------------------------------------------------------------
+
+getAttrRaw :: Monad m
+ => Value m
+ -> Identifier
+ -> m (Either RuntimeError (Maybe (Value m)))
+getAttrRaw (NativeV n) v =
+ Right <$> nativeObjectGetAttribute n v
+getAttrRaw (StringV s) v =
+ case (Map.lookup v builtinStringAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib s
+getAttrRaw (BoolV x) v =
+ case (Map.lookup v builtinBoolAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib x
+getAttrRaw (IntV x) v =
+ case (Map.lookup v builtinIntAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib x
+getAttrRaw (FloatV x) v =
+ case (Map.lookup v builtinFloatAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib x
+getAttrRaw (ListV xs) v =
+ case (Map.lookup v builtinListAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib xs
+getAttrRaw (DictV xs) v =
+ case (Map.lookup v builtinDictAttribs) of
+ Nothing -> pure $ Right Nothing
+ Just attrib -> fmap Just <$> attrib xs
+getAttrRaw _ _ = pure $ Right Nothing
+
+getItemRaw :: Monad m
+ => Value m
+ -> Value m
+ -> m (Maybe (Value m))
+getItemRaw a b = case a of
+ DictV m -> case b of
+ ScalarV k -> pure $ toValue <$> k `Map.lookup` m
+ _ -> pure Nothing
+ ListV xs -> case b of
+ IntV i -> pure . fmap toValue $ xs V.!? (fromInteger i)
+ _ -> pure Nothing
+ StringV str -> case b of
+ IntV i -> pure
+ . fmap (toValue . Text.singleton)
+ . listToMaybe
+ . Text.unpack
+ . Text.take 1
+ . Text.drop (fromInteger i)
+ $ str
+ _ -> pure Nothing
+ NativeV n -> case b of
+ ScalarV k -> nativeObjectGetField n k
+ _ -> pure Nothing
+ _ -> pure Nothing
+
+getAttrOrItemRaw :: Monad m
+ => Value m
+ -> Identifier
+ -> m (Either RuntimeError (Maybe (Value m)))
+getAttrOrItemRaw a i = runExceptT $ do
+ xMay <- eitherExceptM $ getAttrRaw a i
+ case xMay of
+ Just x -> pure . Just $ x
+ Nothing -> lift $ getItemRaw a (StringV . identifierName $ i)
+
+getItemOrAttrRaw :: Monad m
+ => Value m
+ -> Value m
+ -> m (Either RuntimeError (Maybe (Value m)))
+getItemOrAttrRaw a b = runExceptT $ do
+ xMay <- lift $ getItemRaw a b
+ case xMay of
+ Just x -> pure . Just $ x
+ Nothing -> case b of
+ StringV i -> eitherExceptM $ getAttrRaw a (Identifier $ i)
+ _ -> pure Nothing
+
+
+--------------------------------------------------------------------------------
+-- Method and property conversion helpers
+--------------------------------------------------------------------------------
+
+nativeMethod :: Procedure m -> Value m -> Value m
+nativeMethod (NativeProcedure oid doc f) self =
+ ProcedureV . NativeProcedure oid doc $ \args -> f ((Just "value", self) : args)
+nativeMethod (GingerProcedure env argSpec body) self =
+ ProcedureV $ GingerProcedure env' (drop 1 argSpec) body
+ where
+ env' = env { envVars = Map.insert "value" self (envVars env) }
+nativeMethod NamespaceProcedure _self =
+ error "'namespace' cannot be used as a method"
+
+nativePureMethod :: Monad m
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> Either RuntimeError (Value m))
+ -> Value m
+ -> Value m
+nativePureMethod oid doc = nativeMethod . pureNativeFunc oid doc
+
+toNativeMethod :: ToNativeProcedure m a
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> a
+ -> Value m
+ -> Value m
+toNativeMethod oid doc f = nativeMethod (NativeProcedure oid doc $ toNativeProcedure f)
+
+pureAttrib :: Applicative m => (s -> a) -> s -> m (Either RuntimeError a)
+pureAttrib f x = pure . Right $ f x
+
+textBuiltin :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Text -> a)
+ -> Value m
+textBuiltin oid doc f =
+ ProcedureV .
+ pureNativeFunc oid doc .
+ textFunc $
+ (Right . f)
+
+intBuiltin :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Integer -> a)
+ -> Value m
+intBuiltin oid doc f =
+ ProcedureV .
+ pureNativeFunc oid doc .
+ intFunc $
+ (Right . f)
+
+numericBuiltin :: (Monad m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Integer -> Integer)
+ -> (Double -> Double)
+ -> Value m
+numericBuiltin oid doc f g =
+ ProcedureV .
+ pureNativeFunc oid doc $
+ numericFunc f g
+
+anyBuiltin :: (Monad m, FromValue a m, ToValue b m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (a -> b)
+ -> Value m
+anyBuiltin oid doc f =
+ ProcedureV .
+ nativeFunc oid doc $ \x -> runExceptT $
+ toValue . f <$> eitherExceptM (fromValue x)
+
+
+boolProp :: (Monad m, ToValue a m)
+ => (Bool -> a)
+ -> Bool
+ -> m (Either RuntimeError (Value m))
+boolProp f t = pure . Right . toValue $ f t
+
+boolAttrib :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Bool -> a)
+ -> Bool
+ -> m (Either RuntimeError (Value m))
+boolAttrib oid doc f =
+ pureAttrib $ nativePureMethod oid doc (boolFunc f) . BoolV
+
+boolNProcAttrib :: (Monad m, ToNativeProcedure m a)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> a)
+ -> Bool
+ -> m (Either RuntimeError (Value m))
+boolNProcAttrib oid doc f =
+ pureAttrib $ toNativeMethod oid doc f . BoolV
+
+boolProcAttrib :: Monad m
+ => Procedure m
+ -> Bool
+ -> m (Either RuntimeError (Value m))
+boolProcAttrib f =
+ pureAttrib $ nativeMethod f . BoolV
+
+
+intProp :: (Monad m, ToValue a m)
+ => (Integer -> a)
+ -> Integer
+ -> m (Either RuntimeError (Value m))
+intProp f t = pure . Right . toValue $ f t
+
+intAttrib :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Integer -> a)
+ -> Integer
+ -> m (Either RuntimeError (Value m))
+intAttrib oid doc f =
+ pureAttrib $ nativePureMethod oid doc (intFunc (pure . f)) . IntV
+
+intNProcAttrib :: (Monad m, ToNativeProcedure m a)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> a)
+ -> Integer
+ -> m (Either RuntimeError (Value m))
+intNProcAttrib oid doc f =
+ pureAttrib $ toNativeMethod oid doc f . IntV
+
+intProcAttrib :: Monad m
+ => Procedure m
+ -> Integer
+ -> m (Either RuntimeError (Value m))
+intProcAttrib f =
+ pureAttrib $ nativeMethod f . IntV
+
+
+floatProp :: (Monad m, ToValue a m)
+ => (Double -> a)
+ -> Double
+ -> m (Either RuntimeError (Value m))
+floatProp f t = pure . Right . toValue $ f t
+
+floatAttrib :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Double -> a)
+ -> Double
+ -> m (Either RuntimeError (Value m))
+floatAttrib oid doc f =
+ pureAttrib $ nativePureMethod oid doc (floatFunc (pure . f)) . FloatV
+
+floatNProcAttrib :: (Monad m, ToNativeProcedure m a)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> a)
+ -> Double
+ -> m (Either RuntimeError (Value m))
+floatNProcAttrib oid doc f =
+ pureAttrib $ toNativeMethod oid doc f . FloatV
+
+floatProcAttrib :: Monad m
+ => Procedure m
+ -> Double
+ -> m (Either RuntimeError (Value m))
+floatProcAttrib f =
+ pureAttrib $ nativeMethod f . FloatV
+
+
+textProp :: (Monad m, ToValue a m)
+ => (Text -> a)
+ -> Text
+ -> m (Either RuntimeError (Value m))
+textProp f t = pure . Right . toValue $ f t
+
+textAttrib :: (Monad m, ToValue a m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Text -> a)
+ -> Text
+ -> m (Either RuntimeError (Value m))
+textAttrib oid doc f =
+ pureAttrib $ nativePureMethod oid doc (textFunc (pure . f)) . StringV
+
+textNProcAttrib :: (Monad m, ToNativeProcedure m a)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> a)
+ -> Text
+ -> m (Either RuntimeError (Value m))
+textNProcAttrib oid doc f =
+ pureAttrib $ toNativeMethod oid doc f . StringV
+
+textProcAttrib :: Monad m
+ => Procedure m
+ -> Text
+ -> m (Either RuntimeError (Value m))
+textProcAttrib f =
+ pureAttrib $ nativeMethod f . StringV
+
+builtinNotImplemented :: Monad m => Text -> Value m
+builtinNotImplemented name =
+ ProcedureV $
+ NativeProcedure
+ (ObjectID $ "builtin:not_implemented:" <> name)
+ Nothing
+ $ \_ _ ->
+ pure . Left $ NotImplementedError name
+
+fnMaybeArg :: Monad m => Text -> Text -> Maybe b -> ExceptT RuntimeError m b
+fnMaybeArg context name =
+ maybe
+ (throwError $
+ ArgumentError
+ context
+ name
+ "argument"
+ "end of arguments"
+ )
+ pure
+
+fnArg :: (Monad m, FromValue a m)
+ => Text
+ -> Identifier
+ -> Map Identifier (Value m)
+ -> ExceptT RuntimeError m a
+fnArg context name argValues = do
+ argV <- fnMaybeArg context (identifierName name) $ Map.lookup name argValues
+ eitherExceptM $ fromValue argV
+
+describeArg :: Identifier
+ -> Maybe (Value m)
+ -> Maybe TypeDoc
+ -> Text
+ -> ArgumentDoc
+describeArg name defMay ty descr =
+ ArgumentDoc
+ { argumentDocName = identifierName name
+ , argumentDocType = ty
+ , argumentDocDefault = renderSyntaxText <$> defMay
+ , argumentDocDescription = descr
+ }
+
+mkFn0' :: ( Monad m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> Maybe TypeDoc
+ -> (Context m -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn0' funcName desc retType f =
+ NativeProcedure (ObjectID $ "builtin:" <> funcName)
+ (Just ProcedureDoc
+ { procedureDocName = funcName
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = retType
+ , procedureDocDescription = desc
+ }
+ )
+ $ \args ctx -> runExceptT $ do
+ _ <- eitherExcept $
+ resolveArgs
+ funcName
+ []
+ args
+ toValue <$> f ctx
+
+mkFn0 :: ( Monad m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> Maybe TypeDoc
+ -> (ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn0 funcName desc retType f =
+ mkFn0' funcName desc retType (const f)
+
+mkFn1' :: forall m a r.
+ ( Monad m
+ , ToValue a m
+ , FromValue a m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (Context m -> a -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn1' funcName desc (argname1, default1, typedoc1, argdesc1) retType f =
+ NativeProcedure (ObjectID $ "builtin:" <> funcName)
+ (Just ProcedureDoc
+ { procedureDocName = funcName
+ , procedureDocArgs =
+ [ describeArg @m argname1 (toValue <$> default1) typedoc1 argdesc1
+ ]
+ , procedureDocReturnType = retType
+ , procedureDocDescription = desc
+ }
+ )
+ $ \args ctx -> runExceptT $ do
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ [ (argname1, toValue <$> default1)
+ ]
+ args
+ arg1 <- fnArg funcName argname1 argValues
+ toValue <$> f ctx arg1
+
+mkFn1 :: ( Monad m
+ , ToValue a m
+ , FromValue a m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (a -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn1 funcName a desc retType f =
+ mkFn1' funcName a desc retType (const f)
+
+mkFn2' :: forall m a1 a2 r.
+ ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (Context m -> a1 -> a2 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn2' funcName desc
+ (argname1, default1, typedoc1, argdesc1)
+ (argname2, default2, typedoc2, argdesc2)
+ retType
+ f =
+ NativeProcedure (ObjectID $ "builtin:" <> funcName)
+ (Just ProcedureDoc
+ { procedureDocName = funcName
+ , procedureDocArgs =
+ [ describeArg @m argname1 (toValue <$> default1) typedoc1 argdesc1
+ , describeArg @m argname2 (toValue <$> default2) typedoc2 argdesc2
+ ]
+ , procedureDocReturnType = retType
+ , procedureDocDescription = desc
+ }
+ )
+ $ \args ctx -> runExceptT $ do
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ [ (argname1, toValue <$> default1)
+ , (argname2, toValue <$> default2)
+ ]
+ args
+ arg1 <- fnArg funcName argname1 argValues
+ arg2 <- fnArg funcName argname2 argValues
+ toValue <$> f ctx arg1 arg2
+
+mkFn2 :: ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (a1 -> a2 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn2 funcName desc a b retType f =
+ mkFn2' funcName desc a b retType (const f)
+
+mkFn3' :: forall m a1 a2 a3 r.
+ ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue a3 m
+ , FromValue a3 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a3, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (Context m -> a1 -> a2 -> a3 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn3' funcName desc
+ (argname1, default1, typedoc1, argdesc1)
+ (argname2, default2, typedoc2, argdesc2)
+ (argname3, default3, typedoc3, argdesc3)
+ retType
+ f =
+ NativeProcedure (ObjectID $ "builtin:" <> funcName)
+ (Just ProcedureDoc
+ { procedureDocName = funcName
+ , procedureDocArgs =
+ [ describeArg @m argname1 (toValue <$> default1) typedoc1 argdesc1
+ , describeArg @m argname2 (toValue <$> default2) typedoc2 argdesc2
+ , describeArg @m argname3 (toValue <$> default3) typedoc3 argdesc3
+ ]
+ , procedureDocReturnType = retType
+ , procedureDocDescription = desc
+ }
+ )
+ $ \args ctx -> runExceptT $ do
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ [ (argname1, toValue <$> default1)
+ , (argname2, toValue <$> default2)
+ , (argname3, toValue <$> default3)
+ ]
+ args
+ arg1 <- fnArg funcName argname1 argValues
+ arg2 <- fnArg funcName argname2 argValues
+ arg3 <- fnArg funcName argname3 argValues
+ toValue <$> f ctx arg1 arg2 arg3
+
+mkFn3 :: ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue a3 m
+ , FromValue a3 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a3, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (a1 -> a2 -> a3 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn3 funcName desc a b c retType f =
+ mkFn3' funcName desc a b c retType (const f)
+
+mkFn4' :: forall m a1 a2 a3 a4 r.
+ ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue a3 m
+ , FromValue a3 m
+ , ToValue a4 m
+ , FromValue a4 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a3, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a4, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (Context m -> a1 -> a2 -> a3 -> a4 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn4' funcName desc
+ (argname1, default1, typedoc1, argdesc1)
+ (argname2, default2, typedoc2, argdesc2)
+ (argname3, default3, typedoc3, argdesc3)
+ (argname4, default4, typedoc4, argdesc4)
+ retType
+ f =
+ NativeProcedure (ObjectID $ "builtin:" <> funcName)
+ (Just ProcedureDoc
+ { procedureDocName = funcName
+ , procedureDocArgs =
+ [ describeArg @m argname1 (toValue <$> default1) typedoc1 argdesc1
+ , describeArg @m argname2 (toValue <$> default2) typedoc2 argdesc2
+ , describeArg @m argname3 (toValue <$> default3) typedoc3 argdesc3
+ , describeArg @m argname4 (toValue <$> default4) typedoc4 argdesc4
+ ]
+ , procedureDocReturnType = retType
+ , procedureDocDescription = desc
+ }
+ )
+ $ \args ctx -> runExceptT $ do
+ argValues <- eitherExcept $
+ resolveArgs
+ funcName
+ [ (argname1, toValue <$> default1)
+ , (argname2, toValue <$> default2)
+ , (argname3, toValue <$> default3)
+ , (argname4, toValue <$> default4)
+ ]
+ args
+ arg1 <- fnArg funcName argname1 argValues
+ arg2 <- fnArg funcName argname2 argValues
+ arg3 <- fnArg funcName argname3 argValues
+ arg4 <- fnArg funcName argname4 argValues
+ toValue <$> f ctx arg1 arg2 arg3 arg4
+
+mkFn4 :: ( Monad m
+ , ToValue a1 m
+ , FromValue a1 m
+ , ToValue a2 m
+ , FromValue a2 m
+ , ToValue a3 m
+ , FromValue a3 m
+ , ToValue a4 m
+ , FromValue a4 m
+ , ToValue r m
+ )
+ => Text
+ -> Text
+ -> (Identifier, Maybe a1, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a2, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a3, Maybe TypeDoc, Text)
+ -> (Identifier, Maybe a4, Maybe TypeDoc, Text)
+ -> Maybe TypeDoc
+ -> (a1 -> a2 -> a3 -> a4 -> ExceptT RuntimeError m r)
+ -> Procedure m
+mkFn4 funcName desc a b c d retType f =
+ mkFn4' funcName desc a b c d retType (const f)
diff --git a/src/Language/Ginger/Interpret/DefEnv.hs b/src/Language/Ginger/Interpret/DefEnv.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Interpret/DefEnv.hs
@@ -0,0 +1,591 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Language.Ginger.Interpret.DefEnv
+where
+
+import Language.Ginger.AST
+import Language.Ginger.Interpret.Builtins
+import Language.Ginger.Interpret.Eval
+import Language.Ginger.Interpret.Type
+import Language.Ginger.RuntimeError
+import Language.Ginger.Render
+import Language.Ginger.Value
+
+import Control.Monad.Except
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (isJust, fromJust)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LText
+import Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as Builder
+import qualified Data.Vector as V
+
+defEnv :: Monad m => Env m
+defEnv =
+ emptyEnv
+ { envVars = mempty
+ }
+
+defContext :: Monad m => Context m
+defContext =
+ emptyContext
+ { contextVars = defVars
+ , contextEncode = pure . htmlEncode
+ }
+
+htmlEncoder :: Monad m => Encoder m
+htmlEncoder txt = do
+ pure $ htmlEncode txt
+
+htmlEncode :: Text -> Encoded
+htmlEncode txt =
+ (Encoded . LText.toStrict . Builder.toLazyText . Text.foldl' f mempty) txt
+ where
+ f :: Builder -> Char -> Builder
+ f lhs c = lhs <> encodeChar c
+
+ encodeChar :: Char -> Builder
+ encodeChar '&' = "&"
+ encodeChar '<' = "<"
+ encodeChar '>' = ">"
+ encodeChar '"' = """
+ encodeChar '\'' = "'"
+ encodeChar c = Builder.singleton c
+
+defVarsCommon :: forall m. Monad m
+ => Map Identifier (Value m)
+defVarsCommon = Map.fromList
+ [ ( "__jinja__"
+ , dictV
+ [ ( "tests"
+ , dictV
+ [ ("defined", TestV $
+ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = "defined"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether a variable is defined."
+ }
+ )
+ isDefined)
+ , ("undefined", TestV $
+ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = "defined"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether a variable is undefined."
+ }
+ )
+ isUndefined)
+ , ("boolean", fnToValue
+ "builtin:test:boolean"
+ (Just ProcedureDoc
+ { procedureDocName = "boolean"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a boolean."
+ }
+ )
+ (isBool @m))
+ , ("callable", fnToValue
+ "builtin:test:callable"
+ (Just ProcedureDoc
+ { procedureDocName = "callable"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is callable."
+ }
+ )
+ (isCallable @m))
+ , ("filter", TestV $
+ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = "filter"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a filter."
+ }
+ )
+ isFilter)
+ , ("float", fnToValue
+ "builtin:test:float"
+ (Just ProcedureDoc
+ { procedureDocName = "float"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a float."
+ }
+ )
+ (isFloat @m))
+ , ("integer", fnToValue
+ "builtin:test:integer"
+ (Just ProcedureDoc
+ { procedureDocName = "integer"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is an integer."
+ }
+ )
+ (isInteger @m))
+ , ("iterable", fnToValue
+ "builtin:test:iterable"
+ (Just ProcedureDoc
+ { procedureDocName = "iterable"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is iterable.\n"
+ <> "Lists and list-like native objects are iterable."
+ }
+ )
+ (isIterable @m))
+ , ("mapping", fnToValue
+ "builtin:test:mapping"
+ (Just ProcedureDoc
+ { procedureDocName = "mapping"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a mapping.\n"
+ <> "Mappings are dicts and dict-like native objects."
+ }
+ )
+ (isMapping @m))
+ , ("number", fnToValue
+ "builtin:test:number"
+ (Just ProcedureDoc
+ { procedureDocName = "number"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a number (integer or float)."
+ }
+ )
+ (isNumber @m))
+ , ("sequence", fnToValue
+ "builtin:test:sequence"
+ (Just ProcedureDoc
+ { procedureDocName = "sequence"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a sequence (i.e., a list)."
+ }
+ )
+ (isSequence @m))
+ , ("string", fnToValue
+ "builtin:test:string"
+ (Just ProcedureDoc
+ { procedureDocName = "string"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a string."
+ }
+ )
+ (isString @m))
+ , ("test", TestV $
+ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = "test"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a test."
+ }
+ )
+ isTest)
+ , ("upper", fnToValue
+ "builtin:test:upper"
+ (Just ProcedureDoc
+ { procedureDocName = "upper"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is an all-uppercase string."
+ }
+ )
+ (isUpperVal @m))
+ , ("eq", TestV $
+ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = "eq"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is a eq."
+ }
+ )
+ isEqual)
+ , ("escaped", builtinNotImplemented @m "escaped")
+ , ("false", fnToValue
+ "builtin:test:false"
+ (Just ProcedureDoc
+ { procedureDocName = "false"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is boolean `false`"
+ }
+ )
+ (isBoolean False :: Value m -> Value m))
+ , ("ge", gingerBinopTest BinopGTE)
+ , ("gt", gingerBinopTest BinopGT)
+ , ("in", gingerBinopTest BinopIn)
+ , ("le", gingerBinopTest BinopLTE)
+ , ("lower", fnToValue
+ "builtin:test:lower"
+ (Just ProcedureDoc
+ { procedureDocName = "lower"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is an all-lowercase string"
+ }
+ )
+ (isLowerVal @m))
+ , ("lt", gingerBinopTest BinopLT)
+ , ("sameas", builtinNotImplemented @m "sameas")
+ , ("true", fnToValue
+ "builtin:test:true"
+ (Just ProcedureDoc
+ { procedureDocName = "true"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is boolean `true`"
+ }
+ )
+ (isBoolean True :: Value m -> Value m))
+ , ("none", fnToValue
+ "builtin:test:none"
+ (Just ProcedureDoc
+ { procedureDocName = "none"
+ , procedureDocArgs = [ArgumentDoc "value" (Just TypeDocAny) Nothing ""]
+ , procedureDocReturnType = Just $ TypeDocSingle "bool"
+ , procedureDocDescription =
+ "Test whether `value` is the `none` value"
+ }
+ )
+ (isNone :: Value m -> Value m))
+ ]
+ )
+ , ( "filters"
+ , dictV
+ [ ("default", FilterV $ defaultFilter)
+ , ("d", FilterV $ defaultFilter)
+ ]
+ )
+ , ( "globals"
+ , DictV . Map.mapKeys toScalar $ builtinGlobals evalE
+ )
+ ]
+ )
+ ]
+ <> builtinGlobals evalE
+
+defVarsCompat :: forall m. Monad m
+ => Map Identifier (Value m)
+defVarsCompat = defVarsCommon
+
+defVars :: forall m. Monad m
+ => Map Identifier (Value m)
+defVars = defVarsCommon
+ <> builtinGlobalsNonJinja evalE
+ <> Map.fromList
+ [ ( "__ginger__"
+ , dictV
+ [ ( "globals"
+ , DictV . Map.mapKeys toScalar $ builtinGlobalsNonJinja evalE
+ )
+ ]
+ )
+ ]
+
+isCallable' :: Monad m => Value m -> Bool
+isCallable' (ProcedureV {}) = True
+isCallable' (NativeV n) =
+ isJust (nativeObjectCall n)
+isCallable' (DictV d) =
+ maybe (False) isCallable' (Map.lookup "__call__" d)
+isCallable' _ = False
+
+isCallable :: Monad m => Value m -> Value m
+isCallable = BoolV . isCallable'
+
+isFilter :: Monad m => TestFunc m
+isFilter expr _ ctx env = do
+ result <- runGingerT (evalE expr) ctx env
+ case result of
+ Right (StringV name) -> do
+ let exists =
+ isJust (Map.lookup (Identifier name) (envVars env)) ||
+ isJust (Map.lookup (Identifier name) (contextVars ctx))
+ existsExt <-
+ runGingerT
+ (asBool ""
+ =<< eval
+ (InE (StringLitE name) (DotE (VarE "__jinja__") "filters")))
+ ctx env
+ pure $ (exists ||) <$> existsExt
+ Right a ->
+ pure . Left $ TagError "filter name" "string" (tagNameOf a)
+ Left err ->
+ pure $ Left err
+
+isMapping :: Monad m => Value m -> Value m
+isMapping (NativeV {}) = TrueV
+isMapping (DictV {}) = TrueV
+isMapping _ = FalseV
+
+isIterable :: Monad m => Value m -> Value m
+isIterable (NativeV {}) = TrueV
+isIterable (DictV {}) = TrueV
+isIterable (ListV {}) = TrueV
+isIterable _ = FalseV
+
+isSequence :: Monad m => Value m -> Value m
+isSequence (NativeV {}) = TrueV
+isSequence (ListV {}) = TrueV
+isSequence _ = FalseV
+
+isTest :: Monad m => TestFunc m
+isTest expr _ ctx env = do
+ result <- runGingerT (evalE expr) ctx env
+ case result of
+ Right NoneV -> pure . Right $ True
+ Right BoolV {} -> pure . Right $ True
+ Right (StringV name) -> do
+ let testsVars = case Map.lookup "__jinja__" (contextVars ctx) of
+ Just (DictV xs) ->
+ case Map.lookup "tests" xs of
+ Just (DictV ts) -> ts
+ _ -> mempty
+ _ -> mempty
+ let vars =
+ Map.mapKeys (toScalar . identifierName) (contextVars ctx) <>
+ Map.mapKeys (toScalar . identifierName) (envVars env) <>
+ testsVars
+ let existing = Map.lookup (toScalar name) vars
+ case existing of
+ Just a -> pure . Right $ isCallable' a
+ _ -> pure . Right $ False
+
+ Right a ->
+ pure . Left $ TagError "test name" "string" (tagNameOf a)
+ Left err ->
+ pure $ Left err
+
+isEscaped :: Monad m => Value m -> Value m
+isEscaped (EncodedV {}) = TrueV
+isEscaped _ = FalseV
+
+isBool :: Monad m => Value m -> Value m
+isBool (BoolV {}) = TrueV
+isBool _ = FalseV
+
+isInteger :: Monad m => Value m -> Value m
+isInteger (IntV {}) = TrueV
+isInteger _ = FalseV
+
+isFloat :: Monad m => Value m -> Value m
+isFloat (FloatV {}) = TrueV
+isFloat _ = FalseV
+
+isNumber :: Monad m => Value m -> Value m
+isNumber (IntV {}) = TrueV
+isNumber (FloatV {}) = TrueV
+isNumber _ = FalseV
+
+isString :: Monad m => Value m -> Value m
+isString (StringV {}) = TrueV
+isString _ = FalseV
+
+defaultFilter :: Monad m => Filter m
+defaultFilter =
+ NativeFilter
+ (Just $ ProcedureDoc
+ { procedureDocName = "default"
+ , procedureDocArgs =
+ [ ArgumentDoc "value" (Just TypeDocAny) Nothing ""
+ , ArgumentDoc "default" (Just TypeDocAny) Nothing ""
+ ]
+ , procedureDocReturnType = Just $ TypeDocAny
+ , procedureDocDescription =
+ "Return `default` if `value` is `false`, `none`, or undefined, " <>
+ "`value` otherwise."
+ }
+ ) $
+ \expr args ctx env -> do
+ calleeEither <- runGingerT (evalE expr) ctx env
+ let resolvedArgsEither = resolveArgs
+ "default"
+ [("default_value", Just (StringV "")), ("boolean", Just FalseV)]
+ args
+ case (calleeEither, resolvedArgsEither) of
+ (_, Left err) ->
+ pure $ Left err
+ (Right val, Right rargs) ->
+ let defval = fromJust $ Map.lookup "default_value" rargs
+ boolean = fromJust $ Map.lookup "boolean" rargs
+ in case val of
+ NoneV -> pure . Right $ defval
+ FalseV -> pure . Right $ if boolean == TrueV then defval else FalseV
+ a -> pure . Right $ a
+ (Left NotInScopeError {}, Right rargs) ->
+ pure . Right . fromJust $ Map.lookup "default_value" rargs
+ (Left err, _) ->
+ pure . Left $ err
+
+isDefined :: Monad m => TestFunc m
+isDefined _ (_:_) _ _ = pure $ Left $ ArgumentError "defined" "0" "end of arguments" "argument"
+isDefined (PositionedE _ e) [] ctx env =
+ isDefined e [] ctx env
+isDefined (VarE name) [] ctx env =
+ pure . Right $
+ name `Map.member` (envVars env) ||
+ name `Map.member` (contextVars ctx)
+isDefined NoneE [] _ _ = pure . Right $ True
+isDefined BoolE {} [] _ _ = pure . Right $ True
+isDefined StringLitE {} [] _ _ = pure . Right $ True
+isDefined IntLitE {} [] _ _ = pure . Right $ True
+isDefined FloatLitE {} [] _ _ = pure . Right $ True
+isDefined (SliceE slicee startMay endMay) [] ctx env = do
+ definedSlicee <- isDefined slicee [] ctx env
+ definedStart <- maybe (pure . Right $ True) (\start -> isDefined start [] ctx env) startMay
+ definedEnd <- maybe (pure . Right $ True) (\end -> isDefined end [] ctx env) endMay
+ pure $ allEitherBool [ definedSlicee, definedStart, definedEnd ]
+isDefined (IndexE parent selector) [] ctx env = do
+ definedParent <- isDefined parent [] ctx env
+ case definedParent of
+ Right True -> do
+ result <- runGingerT (evalE (InE selector parent)) ctx env
+ case result of
+ Left (NotInScopeError {}) -> pure . Right $ False
+ Left err -> pure . Left $ err
+ Right (BoolV b) -> pure . Right $ b
+ Right _ -> pure . Left $ FatalError "Evaluating an 'in' expression produced non-boolean result"
+ x -> pure x
+isDefined (UnaryE _ a) [] ctx env =
+ isDefined a [] ctx env
+isDefined (BinaryE _ a b) [] ctx env = do
+ definedA <- isDefined a [] ctx env
+ definedB <- isDefined b [] ctx env
+ pure $ (&&) <$> definedA <*> definedB
+isDefined (DotE a _b) [] ctx env = do
+ isDefined a [] ctx env
+isDefined (TernaryE c a b) [] ctx env = do
+ definedA <- isDefined a [] ctx env
+ definedB <- isDefined b [] ctx env
+ definedC <- isDefined c [] ctx env
+ pure $ allEitherBool [definedA, definedB, definedC]
+isDefined (ListE v) [] ctx env =
+ case V.uncons v of
+ Nothing -> pure . Right $ True
+ Just (x, xs) -> do
+ definedX <- isDefined x [] ctx env
+ definedXS <- isDefined (ListE xs) [] ctx env
+ pure $ allEitherBool [definedX, definedXS]
+isDefined (DictE []) [] _ _ = pure . Right $ True
+isDefined (DictE ((k, v):xs)) [] ctx env = do
+ definedK <- isDefined k [] ctx env
+ definedV <- isDefined v [] ctx env
+ definedXS <- isDefined (DictE xs) [] ctx env
+ pure $ allEitherBool [definedK, definedV, definedXS]
+isDefined (IsE {}) [] _ _ = pure . Right $ True
+isDefined (StatementE {}) [] _ _ = pure . Right $ True
+isDefined (FilterE posArg0 callee posArgs kwArgs) [] ctx env = do
+ definedPosArg0 <- isDefined posArg0 [] ctx env
+ definedCallee <- isDefined callee [] ctx env
+ definedPosArgs <- allEitherBool <$> mapM (\x -> isDefined x [] ctx env) posArgs
+ definedKWArgs <- allEitherBool <$> mapM (\(_, x) -> isDefined x [] ctx env) kwArgs
+ pure $ allEitherBool [definedPosArg0, definedCallee, definedPosArgs, definedKWArgs]
+isDefined (CallE callee posArgs kwArgs) [] ctx env = do
+ definedCallee <- isDefined callee [] ctx env
+ definedPosArgs <- allEitherBool <$> mapM (\x -> isDefined x [] ctx env) posArgs
+ definedKWArgs <- allEitherBool <$> mapM (\(_, x) -> isDefined x [] ctx env) kwArgs
+ pure $ allEitherBool [definedCallee, definedPosArgs, definedKWArgs]
+
+isUndefined :: Monad m => TestFunc m
+isUndefined expr args ctx env = do
+ defined <- isDefined expr args ctx env
+ pure $ not <$> defined
+
+isEqual :: Monad m => TestFunc m
+isEqual expr args ctx env = runGingerT go ctx env
+ where
+ go = do
+ definedLHS <- native $ isDefined expr args ctx env
+ if definedLHS then do
+ val <- eval expr
+ equals <- mapM (valuesEqual val . snd) args
+ pure $ all id equals
+ else
+ pure False
+
+gingerBinopTest :: forall m. Monad m
+ => BinaryOperator
+ -> Value m
+gingerBinopTest op =
+ TestV $ NativeTest
+ (Just ProcedureDoc
+ { procedureDocName = opName
+ , procedureDocArgs =
+ [ ArgumentDoc "expr" (Just TypeDocAny) Nothing ""
+ , ArgumentDoc "arg" (Just TypeDocAny) Nothing ""
+ ]
+ , procedureDocReturnType = Just $ TypeDocAny
+ , procedureDocDescription =
+ "Apply the '" <> opName <> "' operation to the value of `expr` " <>
+ "and the `arg`, and use the result as a boolean condition."
+ })
+ f
+ where
+ opName :: Text
+ opName = renderSyntaxText op
+
+ f :: TestFunc m
+ f expr args ctx env = runGingerT (go expr args) ctx env
+
+ go expr args = scoped $ do
+ setVar "#args" (ListV . V.fromList $ map snd args)
+ eval (BinaryE op expr (VarE "#args")) >>= \case
+ TrueV -> pure True
+ _ -> pure False
+
+fnEither :: Monad m => Either a b -> ExceptT a m b
+fnEither = either throwError pure
+
+fnMaybeArg :: Monad m => Text -> Text -> Maybe b -> ExceptT RuntimeError m b
+fnMaybeArg context name =
+ maybe
+ (throwError $
+ ArgumentError
+ context
+ name
+ "argument"
+ "end of arguments"
+ )
+ pure
diff --git a/src/Language/Ginger/Interpret/Eval.hs b/src/Language/Ginger/Interpret/Eval.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Interpret/Eval.hs
@@ -0,0 +1,901 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Language.Ginger.Interpret.Eval
+( Eval (..)
+, EvalState (..)
+, evalE
+, evalS
+, evalSs
+, evalT
+, stringify
+, valuesEqual
+, asBool
+, getAttr
+, getAttrRaw
+, getItem
+, getItemRaw
+, loadTemplate
+)
+where
+
+import Language.Ginger.AST
+import Language.Ginger.Interpret.Builtins
+import Language.Ginger.Interpret.Type
+import Language.Ginger.Parse (parseGinger)
+import qualified Language.Ginger.Parse as Parse
+import Language.Ginger.RuntimeError
+import Language.Ginger.Value
+import Language.Ginger.SourcePosition
+
+import Control.Monad (foldM, forM, void)
+import Control.Monad.Except
+ ( MonadError (..)
+ , throwError
+ )
+import Control.Monad.Reader (ask , asks, local, MonadReader (..))
+import Control.Monad.State (gets)
+import Control.Monad.Trans (lift, MonadTrans (..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as LBS
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes, fromMaybe)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Digest.Pure.SHA (sha256, showDigest)
+import Data.Text.Encoding (encodeUtf8)
+
+hashShow :: Show a => a -> Text
+hashShow = Text.pack . showDigest . sha256 . LBS.fromStrict . encodeUtf8 . Text.show
+
+loadTemplate :: Monad m => Text -> GingerT m LoadedTemplate
+loadTemplate name = do
+ sMay <- loadTemplateMaybe name
+ case sMay of
+ Nothing -> throwError $ TemplateFileNotFoundError name
+ Just s -> pure s
+
+loadTemplateMaybe :: Monad m => Text -> GingerT m (Maybe LoadedTemplate)
+loadTemplateMaybe name = do
+ loader <- asks contextLoadTemplateFile
+ srcMay <- lift (loader name)
+ case srcMay of
+ Nothing -> pure Nothing
+ Just src -> do
+ let result = parseGinger Parse.template (Text.unpack name) src
+ case result of
+ Left err ->
+ throwError $ TemplateParseError name (Text.pack err)
+ Right t -> do
+ parent <- forM (templateParent t) loadTemplate
+ let body = templateBody t
+ pure . Just $ LoadedTemplate parent body
+
+mapArgs :: forall m. Monad m
+ => Text
+ -> [(Identifier, Maybe (Value m))]
+ -> [(Maybe Identifier, Value m)]
+ -> GingerT m (Map Identifier (Value m))
+mapArgs context spec args =
+ go spec posArgs kwArgs
+ where
+ posArgs = [ v | (Nothing, v) <- args ]
+ kwArgs = Map.fromList [ (k, v) | (Just k, v) <- args ]
+
+ go :: [(Identifier, Maybe (Value m))]
+ -> [Value m]
+ -> Map Identifier (Value m)
+ -> GingerT m (Map Identifier (Value m))
+ go ((name, defEMay):specs) ps kw = do
+ case Map.lookup name kw of
+ Just val -> do
+ -- Found keyword argument
+ let cur = Map.singleton name val
+ rest <- go specs ps (Map.delete name kw)
+ pure $ cur <> rest
+ Nothing ->
+ -- No keyword argument found, look for positional argument
+ case ps of
+ (val:ps') -> do
+ let cur = Map.singleton name val
+ rest <- go specs ps' kw
+ pure $ cur <> rest
+ [] -> do
+ -- No positional argument found, see if we have a default
+ case defEMay of
+ Just defE -> do
+ let cur = Map.singleton name defE
+ rest <- go specs ps kw
+ pure $ cur <> rest
+ Nothing ->
+ throwError $ ArgumentError context (identifierName name) "argument" "end of arguments"
+ go [] _ _ =
+ pure mempty
+
+evalCallArgs :: Monad m => [Expr] -> [(Identifier, Expr)] -> GingerT m [(Maybe Identifier, Value m)]
+evalCallArgs posArgsExpr namedArgsExpr = do
+ posArgs <- mapM evalE posArgsExpr
+ namedArgs <- mapM evalNamedArg namedArgsExpr
+ pure $ zip (repeat Nothing) posArgs ++ namedArgs
+
+callTest :: Monad m => Value m -> Expr -> [Expr] -> [(Identifier, Expr)] -> GingerT m (Value m)
+callTest testV scrutinee posArgsExpr namedArgsExpr = do
+ case testV of
+ TestV t -> do
+ args <- evalCallArgs posArgsExpr namedArgsExpr
+ ctx <- ask
+ env <- gets evalEnv
+ BoolV <$> native (runTest t scrutinee args ctx env)
+
+ ScalarV {} -> do
+ BoolV <$> (valuesEqual testV =<< evalE scrutinee)
+ `catchError` \err -> case err of
+ NotInScopeError {} -> pure FalseV
+ _ -> throwError err
+
+ x -> do
+ call Nothing x (scrutinee : posArgsExpr) namedArgsExpr
+
+callFilter :: Monad m => Value m -> Expr -> [Expr] -> [(Identifier, Expr)] -> GingerT m (Value m)
+callFilter filterV scrutinee posArgsExpr namedArgsExpr = do
+ case filterV of
+ FilterV f -> do
+ args <- evalCallArgs posArgsExpr namedArgsExpr
+ ctx <- ask
+ env <- gets evalEnv
+ native (runFilter f scrutinee args ctx env)
+
+ ScalarV {} -> do
+ BoolV <$> (valuesEqual filterV =<< evalE scrutinee)
+ `catchError` \err -> case err of
+ NotInScopeError {} -> pure FalseV
+ _ -> throwError err
+
+ x -> do
+ call Nothing x (scrutinee : posArgsExpr) namedArgsExpr
+
+
+call :: Monad m => Maybe (Value m) -> Value m -> [Expr] -> [(Identifier, Expr)] -> GingerT m (Value m)
+call callerMay callable posArgsExpr namedArgsExpr = do
+ args <- evalCallArgs posArgsExpr namedArgsExpr
+ case callable of
+ ProcedureV (NativeProcedure _ _ f) ->
+ withEnv mempty $ do
+ ctx <- ask
+ native $ f args ctx
+ ProcedureV (GingerProcedure env argsSig f) -> do
+ withEnv env $ do
+ maybe (pure ()) (setVar "caller") callerMay
+ argDict <- mapArgs "macro" argsSig args
+ scoped $ do
+ setVars argDict
+ evalE f
+ ProcedureV NamespaceProcedure -> do
+ refID <- allocMutable (DictV mempty)
+ pure $ MutableRefV refID
+ DictV m -> do
+ let callable' = Map.lookup "__call__" m
+ case callable' of
+ Nothing -> throwError $ NonCallableObjectError "dict"
+ Just c -> call callerMay c posArgsExpr namedArgsExpr
+ NativeV obj -> do
+ case nativeObjectCall obj of
+ Just f -> native $ f obj args
+ Nothing -> throwError $ NonCallableObjectError "native object"
+ x ->
+ throwError $ NonCallableObjectError (tagNameOf x)
+
+-- | 'Eval' represents types that can be evaluated in some 'GingerT m' monadic
+-- context.
+class Eval m a where
+ eval :: a -> GingerT m (Value m)
+
+instance Monad m => Eval m Expr where
+ eval = evalE
+
+instance Monad m => Eval m Statement where
+ eval = evalS
+
+instance Monad m => Eval m Template where
+ eval = evalT
+
+-- | Evaluate an expression, dereferencing mutable refs.
+evalE :: Monad m => Expr -> GingerT m (Value m)
+evalE expr =
+ evalE' expr >>= \case
+ MutableRefV refID -> derefMutable refID
+ v -> pure v
+
+-- | Evaluate an expression without dereferencing mutable refs.
+evalE' :: Monad m => Expr -> GingerT m (Value m)
+evalE' (PositionedE pos e) = do
+ evalE e `catchError` decorateError pos
+evalE' NoneE = pure NoneV
+evalE' (BoolE b) = pure (BoolV b)
+evalE' (StringLitE s) = pure (StringV s)
+evalE' (IntLitE i) = pure (IntV i)
+evalE' (FloatLitE d) = pure (FloatV d)
+evalE' (ListE xs) = ListV <$> V.mapM evalE xs
+evalE' (DictE xs) =
+ DictV . Map.fromList <$> mapM evalKV xs
+evalE' (UnaryE op expr) = do
+ v <- evalE expr
+ evalUnary op v
+evalE' (BinaryE op aExpr bExpr) = do
+ a <- evalE aExpr
+ b <- evalE bExpr
+ evalBinary op a b
+evalE' (DotE aExpr b) = do
+ a <- evalE aExpr
+ attrMay <- getAttr a b
+ case attrMay of
+ Just attr -> pure attr
+ Nothing -> do
+ itemMay <- getItem a (StringV . identifierName $ b)
+ case itemMay of
+ Just item -> pure item
+ Nothing -> throwError $ NotInScopeError (Text.show a <> "." <> Text.show b)
+evalE' (SliceE sliceeE beginEMay endEMay) = do
+ slicee <- evalE sliceeE
+ beginMay <- mapM evalE beginEMay
+ endMay <- mapM evalE endEMay
+ sliceValue slicee beginMay endMay
+evalE' (CallE callableExpr posArgsExpr namedArgsExpr) = do
+ callable <- evalE callableExpr
+ call Nothing callable posArgsExpr namedArgsExpr
+evalE' (FilterE scrutinee filterE args kwargs) = do
+ f <- withJinjaFilters (eval filterE)
+ callFilter f scrutinee args kwargs
+evalE' (TernaryE condExpr yesExpr noExpr) = do
+ cond <- evalE condExpr >>= asBool "condition"
+ evalE (if cond then yesExpr else noExpr)
+evalE' (VarE name) =
+ lookupVar name
+evalE' (StatementE statement) = do
+ evalS statement
+evalE' (IsE scrutinee testE args kwargs) = do
+ t <- withJinjaTests (evalE testE)
+ callTest t scrutinee args kwargs
+
+evalKV :: Monad m => (Expr, Expr) -> GingerT m (Scalar, Value m)
+evalKV (kExpr, vExpr) = do
+ kVal <- evalE kExpr
+ kScalar <- case kVal of
+ ScalarV s -> pure s
+ x -> throwError $ TagError "dict key" "scalar" (tagNameOf x)
+ vVal <- evalE vExpr
+ return (kScalar, vVal)
+
+evalNamedArg :: Monad m => (Identifier, Expr) -> GingerT m (Maybe Identifier, Value m)
+evalNamedArg (kIdent, vExpr) = do
+ vVal <- evalE vExpr
+ return (Just kIdent, vVal)
+
+sliceVector :: Vector a -> Maybe Int -> Maybe Int -> Vector a
+sliceVector xs startMay endMay =
+ let start = case startMay of
+ Nothing -> 0
+ Just n | n < 0 -> V.length xs + n
+ Just n -> n
+ end = case endMay of
+ Nothing -> V.length xs - start
+ Just n | n < 0 -> V.length xs - start + n
+ Just n -> n
+ in V.take end . V.drop start $ xs
+
+sliceText :: Text -> Maybe Int -> Maybe Int -> Text
+sliceText xs startMay endMay =
+ let start = case startMay of
+ Nothing -> 0
+ Just n | n < 0 -> Text.length xs + n
+ Just n -> n
+ end = case endMay of
+ Nothing -> Text.length xs - start
+ Just n | n < 0 -> Text.length xs - start + n
+ Just n -> n
+ in Text.take end . Text.drop start $ xs
+
+sliceByteString :: ByteString -> Maybe Int -> Maybe Int -> ByteString
+sliceByteString xs startMay endMay =
+ let start = case startMay of
+ Nothing -> 0
+ Just n | n < 0 -> ByteString.length xs + n
+ Just n -> n
+ end = case endMay of
+ Nothing -> ByteString.length xs - start
+ Just n | n < 0 -> ByteString.length xs - start + n
+ Just n -> n
+ in ByteString.take end . ByteString.drop start $ xs
+
+sliceValue :: Monad m
+ => Value m
+ -> Maybe (Value m)
+ -> Maybe (Value m)
+ -> GingerT m (Value m)
+sliceValue (ListV xs) startValMay endValMay = do
+ startMay <- mapM (native . pure . asIntVal) startValMay
+ endMay <- mapM (native . pure . asIntVal) endValMay
+ pure . ListV $ sliceVector xs (fromIntegral <$> startMay) (fromIntegral <$> endMay)
+sliceValue (StringV xs) startValMay endValMay = do
+ startMay <- mapM (native . pure . asIntVal) startValMay
+ endMay <- mapM (native . pure . asIntVal) endValMay
+ pure . StringV $ sliceText xs (fromIntegral <$> startMay) (fromIntegral <$> endMay)
+sliceValue (BytesV xs) startValMay endValMay = do
+ startMay <- mapM (native . pure . asIntVal) startValMay
+ endMay <- mapM (native . pure . asIntVal) endValMay
+ pure . BytesV $ sliceByteString xs (fromIntegral <$> startMay) (fromIntegral <$> endMay)
+sliceValue (EncodedV (Encoded xs)) startValMay endValMay = do
+ startMay <- mapM (native . pure . asIntVal) startValMay
+ endMay <- mapM (native . pure . asIntVal) endValMay
+ pure . EncodedV . Encoded $ sliceText xs (fromIntegral <$> startMay) (fromIntegral <$> endMay)
+sliceValue x _ _ =
+ throwError $
+ TagError "slicee" "list or string" (tagNameOf x)
+
+numericBinop :: Monad m
+ => (Integer -> Integer -> Integer)
+ -> (Double -> Double -> Double)
+ -> Value m
+ -> Value m
+ -> GingerT m (Value m)
+numericBinop f g a b = native . pure $ numericFunc2 f g a b
+
+numericBinopCatch :: Monad m
+ => (Integer -> Integer -> Either RuntimeError Integer)
+ -> (Double -> Double -> Either RuntimeError Double)
+ -> Value m
+ -> Value m
+ -> GingerT m (Value m)
+numericBinopCatch f g a b = native . pure $ numericFunc2Catch f g a b
+
+intBinop :: Monad m
+ => (Integer -> Integer -> Either RuntimeError Integer)
+ -> Value m
+ -> Value m
+ -> GingerT m (Value m)
+intBinop f a b = native . pure $ intFunc2 f a b
+
+floatBinop :: Monad m
+ => (Double -> Double -> Either RuntimeError Double)
+ -> Value m
+ -> Value m
+ -> GingerT m (Value m)
+floatBinop f a b = native . pure $ floatFunc2 f a b
+
+boolBinop :: Monad m
+ => (Bool -> Bool -> Bool)
+ -> Value m
+ -> Value m
+ -> GingerT m (Value m)
+boolBinop f a b = native . pure $ boolFunc2 f a b
+
+
+valuesEqual :: Monad m
+ => Value m
+ -> Value m
+ -> GingerT m Bool
+valuesEqual NoneV NoneV = pure True
+valuesEqual (IntV a) (IntV b) = pure (a == b)
+valuesEqual (FloatV a) (FloatV b) = pure (a == b)
+valuesEqual (StringV a) (StringV b) = pure (a == b)
+valuesEqual (BoolV a) (BoolV b) = pure (a == b)
+valuesEqual (BytesV a) (BytesV b) = pure (a == b)
+valuesEqual (EncodedV a) (EncodedV b) = pure (a == b)
+valuesEqual (ListV a) (ListV b)
+ | V.length a /= V.length b
+ = pure False
+ | otherwise
+ = V.and <$> V.zipWithM valuesEqual a b
+valuesEqual (DictV a) (DictV b) = dictsEqual a b
+valuesEqual (NativeV a) (NativeV b) =
+ native $ a --> nativeObjectEq b
+valuesEqual a b = pure (a == b)
+
+compareValues :: Monad m => Value m -> Value m -> GingerT m Ordering
+compareValues NoneV NoneV = pure $ EQ
+compareValues (BoolV a) (BoolV b) = pure $ compare a b
+compareValues (IntV a) (IntV b) = pure $ compare a b
+compareValues (FloatV a) (FloatV b) = pure $ compare a b
+compareValues (IntV a) (FloatV b) = pure $ compare (fromInteger a) b
+compareValues (FloatV a) (IntV b) = pure $ compare a (fromInteger b)
+compareValues (StringV a) (StringV b) = pure $ compare a b
+compareValues (EncodedV a) (EncodedV b) = pure $ compare a b
+compareValues a b = throwError $ TagError "comparison" "comparable types" (tagNameOf a <> ", " <> tagNameOf b)
+
+valueComparison :: Monad m => (Ordering -> Bool) -> Value m -> Value m -> GingerT m (Value m)
+valueComparison f a b = do
+ ordering <- compareValues a b
+ pure $ BoolV (f ordering)
+
+dictsEqual :: forall m. Monad m
+ => Map Scalar (Value m)
+ -> Map Scalar (Value m)
+ -> GingerT m Bool
+dictsEqual m1 m2 =
+ and <$> mapM (\k -> (valuesEqual (toValue $ Map.lookup k m1) (toValue $ Map.lookup k m2))) keys
+ where
+ keys = Set.toList (Map.keysSet m1 <> Map.keysSet m2)
+
+evalUnary :: Monad m => UnaryOperator -> Value m -> GingerT m (Value m)
+evalUnary UnopNot (BoolV b) = pure (BoolV $ not b)
+evalUnary UnopNot x = throwError $ TagError "not" "boolean" (tagNameOf x)
+evalUnary UnopNegate (IntV x) = pure (IntV $ negate x)
+evalUnary UnopNegate (FloatV x) = pure (FloatV $ negate x)
+evalUnary UnopNegate x = throwError $ TagError "unary -" "number" (tagNameOf x)
+
+evalBinary :: Monad m => BinaryOperator -> Value m -> Value m -> GingerT m (Value m)
+evalBinary BinopPlus a b = numericBinop (+) (+) a b
+evalBinary BinopMinus a b = numericBinop (-) (-) a b
+evalBinary BinopDiv a b = floatBinop safeDiv a b
+evalBinary BinopIntDiv a b = intBinop safeIntDiv a b
+evalBinary BinopMod a b = intBinop safeIntMod a b
+evalBinary BinopMul a b = numericBinop (*) (*) a b
+evalBinary BinopPower a b = numericBinopCatch safeIntPow (\x y -> Right (x ** y)) a b
+evalBinary BinopEqual a b = BoolV <$> valuesEqual a b
+evalBinary BinopNotEqual a b = BoolV . not <$> valuesEqual a b
+evalBinary BinopGT a b = valueComparison (== GT) a b
+evalBinary BinopGTE a b = valueComparison (/= LT) a b
+evalBinary BinopLT a b = valueComparison (== LT) a b
+evalBinary BinopLTE a b = valueComparison (/= GT) a b
+
+evalBinary BinopAnd a b = boolBinop (&&) a b
+evalBinary BinopOr a b = boolBinop (||) a b
+evalBinary BinopIn a b = case b of
+ DictV m -> case a of
+ ScalarV k -> pure . BoolV $ k `Map.member` m
+ x -> throwError $ TagError "in" "scalar" (tagNameOf x)
+ ListV v -> case V.uncons v of
+ Nothing ->
+ pure FalseV
+ Just (x, xs) -> do
+ found <- valuesEqual a x
+ if found then
+ pure . BoolV $ True
+ else
+ evalBinary BinopIn a (ListV xs)
+ x -> throwError $ TagError "in" "list or dict" (tagNameOf x)
+evalBinary BinopIndex a b = do
+ itemMay <- getItem a b
+ case itemMay of
+ Just item -> pure item
+ Nothing -> do
+ attrMay <- case b of
+ StringV s -> getAttr a (Identifier s)
+ _ -> pure Nothing
+ case attrMay of
+ Just attr -> pure attr
+ Nothing -> pure NoneV
+evalBinary BinopConcat a b = concatValues a b
+
+getItem :: Monad m
+ => Value m
+ -> Value m
+ -> GingerT m (Maybe (Value m))
+getItem a b = lift $ getItemRaw a b
+
+
+getAttr :: Monad m
+ => Value m
+ -> Identifier
+ -> GingerT m (Maybe (Value m))
+getAttr a b = native $ getAttrRaw a b
+
+safeIntPow :: Integer -> Integer -> Either RuntimeError Integer
+safeIntPow _ b | b < 0 = Left (NumericError "**" "negative exponent")
+safeIntPow a b = Right (a ^ b)
+
+safeIntDiv :: Integer -> Integer -> Either RuntimeError Integer
+safeIntDiv _ 0 = Left (NumericError "//" "division by zero")
+safeIntDiv a b = Right (a `div` b)
+
+safeIntMod :: Integer -> Integer -> Either RuntimeError Integer
+safeIntMod _ 0 = Left (NumericError "%" "modulo by zero")
+safeIntMod a b = Right (a `mod` b)
+
+safeDiv :: Double -> Double -> Either RuntimeError Double
+safeDiv a b =
+ case a / b of
+ c | isNaN c -> Left (NumericError "/" "not a number")
+ c | isInfinite c -> Left (NumericError "/" ("division by zero"))
+ c -> Right c
+
+concatValues :: Monad m => (Value m) -> (Value m) -> GingerT m (Value m)
+concatValues a b = case (a, b) of
+ -- Strings, blobs and encoded values concatenate directly
+ (StringV x, StringV y) -> pure $ StringV $ x <> y
+ (BytesV x, BytesV y) -> pure $ BytesV $ x <> y
+ (EncodedV (Encoded x), EncodedV (Encoded y)) -> pure . EncodedV . Encoded $ x <> y
+
+ -- None is a neutral element
+ (NoneV, y) -> pure $ y
+ (x, NoneV) -> pure $ x
+
+ -- Anything involving encoded values yields encoded results
+ (EncodedV x, y) -> do
+ yEnc <- encode y
+ pure $ EncodedV (x <> yEnc)
+ (x, EncodedV y) -> do
+ xEnc <- encode x
+ pure $ EncodedV (xEnc <> y)
+
+ -- Anything else is cast to and concatenated as strings
+ (x, y) -> do
+ xStr <- stringify x
+ yStr <- stringify y
+ pure . StringV $ xStr <> yStr
+
+evalT :: Monad m => Template -> GingerT m (Value m)
+evalT t = do
+ case templateParent t of
+ Nothing ->
+ evalS (templateBody t)
+ Just parentName -> do
+ parent <- loadTemplate parentName
+ hush_ $ evalS (templateBody t)
+ evalLT parent
+
+evalLT :: Monad m => LoadedTemplate -> GingerT m (Value m)
+evalLT t = do
+ case loadedTemplateParent t of
+ Nothing ->
+ evalS (loadedTemplateBody t)
+ Just parent -> do
+ hush_ $ evalS (loadedTemplateBody t)
+ evalLT parent
+
+evalS :: Monad m => Statement -> GingerT m (Value m)
+evalS (PositionedS pos s) = do
+ evalS s `catchError` decorateError pos
+evalS (ImmediateS enc) = pure (EncodedV enc)
+evalS (InterpolationS expr) = whenOutputPolicy $ do
+ evalE expr
+evalS (CommentS _) = pure NoneV
+evalS (ForS loopKeyMay loopName itereeE loopCondMay recursivity bodyS elseSMay) = do
+ iteree <- evalE itereeE
+ evalLoop loopKeyMay loopName iteree loopCondMay recursivity bodyS elseSMay 0
+evalS (IfS condE yesS noSMay) = do
+ cond <- evalE condE >>= asBool "condition"
+ if cond then evalS yesS else maybe (pure NoneV) evalS noSMay
+evalS (MacroS name argsSig body) = do
+ env <- gets evalEnv
+ argsSig' <- mapM (\(argname, defEMay) -> do
+ defMay <- maybe (pure Nothing) (fmap Just . evalE) defEMay
+ pure (argname, defMay)
+ )
+ argsSig
+ setVar name . ProcedureV $ GingerProcedure env argsSig' (StatementE body)
+ pure NoneV
+
+evalS (CallS name posArgsExpr namedArgsExpr bodyS) = whenOutputPolicy $ do
+ callee <- lookupVar name
+ callerVal <- eval bodyS
+ srcPosMay <- gets evalSourcePosition
+ let callerID =
+ objectIDFromContext "caller" callerVal srcPosMay
+ let caller =
+ ProcedureV $
+ NativeProcedure
+ callerID
+ (Just ProcedureDoc
+ { procedureDocName = "caller"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = Just $ TypeDocSingle "markup"
+ , procedureDocDescription =
+ "Runs the body of the {% call %} statement that called the " <>
+ "current macro."
+ }
+ )
+ (const . const . pure . Right $ callerVal)
+ call (Just caller) callee posArgsExpr namedArgsExpr
+evalS (FilterS name posArgsExpr namedArgsExpr bodyS) = whenOutputPolicy $ do
+ callee <- lookupVar name
+ let posArgsExpr' = StatementE bodyS : posArgsExpr
+ call Nothing callee posArgsExpr' namedArgsExpr
+
+evalS (SetS target valE) = do
+ val <- evalE' valE
+ case target of
+ SetVar name -> setVar name val
+ SetMutable name attr -> setMutable name attr val
+ pure NoneV
+evalS (SetBlockS target bodyS filterEMaybe) = do
+ body <- case filterEMaybe of
+ Nothing ->
+ evalS bodyS
+ Just filterE -> case filterE of
+ CallE callee posArgs kwArgs ->
+ evalE (CallE callee (StatementE bodyS : posArgs) kwArgs)
+ callee ->
+ evalE (CallE callee [StatementE bodyS] mempty)
+ case target of
+ SetVar name -> setVar name body
+ SetMutable name path -> setMutable name path body
+ pure NoneV
+evalS (IncludeS nameE missingPolicy contextPolicy) = do
+ name <- eval nameE >>= (eitherExcept . asTextVal)
+ templateMay <- case missingPolicy of
+ RequireMissing -> Just <$> loadTemplate name
+ IgnoreMissing -> loadTemplateMaybe name
+ case templateMay of
+ Nothing ->
+ pure NoneV
+ Just template -> do
+ withScopeModifier (contextPolicy == WithContext) $ evalLT template
+evalS (ImportS srcE nameMay identifiers missingPolicy contextPolicy) = hush $ do
+ src <- eval srcE >>= (eitherExcept . asTextVal)
+ templateMay <- case missingPolicy of
+ RequireMissing -> Just <$> loadTemplate src
+ IgnoreMissing -> loadTemplateMaybe src
+ case templateMay of
+ Nothing ->
+ pure NoneV
+ Just template -> do
+ e' <- scoped . withScopeModifier (contextPolicy == WithContext) $ do
+ void $ evalLT template
+ gets evalEnv
+ let vars = case identifiers of
+ Nothing ->
+ case nameMay of
+ Nothing -> envVars e'
+ Just name -> Map.singleton name (DictV . Map.mapKeys toScalar $ envVars e')
+ Just importees -> Map.fromList . catMaybes $
+ [ (fromMaybe varName alias,) <$> Map.lookup varName (envVars e')
+ | (varName, alias) <- importees
+ ]
+ setVars vars
+ pure NoneV
+evalS (BlockS name block) =
+ evalBlock name block
+evalS (WithS varEs bodyS) = do
+ vars <- Map.fromList <$> mapM (\(k, valE) -> (k,) <$> evalE valE) varEs
+ scoped $ do
+ setVars vars
+ evalS bodyS
+evalS (GroupS xs) = evalSs xs
+
+objectIDFromContext :: Show a
+ => Text
+ -> a
+ -> Maybe SourcePosition
+ -> ObjectID
+objectIDFromContext prefix x posMay =
+ ObjectID $
+ prefix <> ":" <> maybe (hashShow x) hashShow posMay
+
+hush :: Monad m => GingerT m a -> GingerT m a
+hush = local (\c -> c { contextOutput = Quiet })
+
+hush_ :: Monad m => GingerT m a -> GingerT m ()
+hush_ = void . hush
+
+whenOutputPolicy :: Monad m => GingerT m (Value m) -> GingerT m (Value m)
+whenOutputPolicy action = do
+ outputPolicy <- asks contextOutput
+ if outputPolicy == Output then
+ action
+ else
+ pure NoneV
+
+withScopeModifier :: Monad m => Bool -> GingerT m a -> GingerT m a
+withScopeModifier policy inner = do
+ let scopeModifier = if policy then id else withoutContext
+ scopeModifier inner
+
+evalBlock :: Monad m => Identifier -> Block -> GingerT m (Value m)
+evalBlock name block = do
+ lblock <- setBlock name block
+ super <- makeSuper (loadedBlockParent lblock)
+ whenOutputPolicy .
+ withScopeModifier (is $ lblockScoped lblock) .
+ scoped $ do
+ setVar "super" super
+ evalS (blockBody . loadedBlock $ lblock)
+
+lblockScoped :: LoadedBlock -> Scoped
+lblockScoped lb =
+ case loadedBlockParent lb of
+ Nothing -> blockScoped (loadedBlock lb)
+ Just parent -> lblockScoped parent
+
+makeSuper :: Monad m => Maybe LoadedBlock -> GingerT m (Value m)
+makeSuper Nothing = pure NoneV
+makeSuper (Just lblock) = do
+ ctx <- ask
+ env <- gets evalEnv
+ parent <- makeSuper (loadedBlockParent lblock)
+ pure $ dictV
+ [ "__call__" .=
+ ProcedureV
+ (mkFn0 "super()"
+ "Evaluate the parent template"
+ Nothing $
+ eitherExceptM $
+ runGingerT
+ (evalS . blockBody . loadedBlock $ lblock)
+ ctx
+ env
+ )
+ , "super" .= parent
+ ]
+
+asBool :: Monad m => Text -> Value m -> GingerT m Bool
+asBool _ (BoolV b) = pure b
+asBool _ NoneV = pure False
+asBool context x = throwError $ TagError context "boolean" (tagNameOf x)
+
+evalLoop :: forall m. Monad m
+ => Maybe Identifier
+ -> Identifier
+ -> Value m
+ -> Maybe Expr
+ -> Recursivity
+ -> Statement
+ -> Maybe Statement
+ -> Int
+ -> GingerT m (Value m)
+evalLoop loopKeyMay loopName iteree loopCondMay recursivity bodyS elseSMay recursionLevel = do
+ -- First, convert the iteree into a plain list.
+
+ itemPairs <- case iteree of
+ ListV items -> pure (V.zip (fmap IntV [0..]) items)
+ DictV dict -> (pure . V.fromList) [ (ScalarV k, v) | (k, v) <- Map.toList dict ]
+ NoneV -> pure mempty
+ x -> throwError $ TagError "iteree" "list or dict" (tagNameOf x)
+
+ filtered <- maybe (pure itemPairs) (goFilter itemPairs) loopCondMay
+
+ if null filtered then
+ case elseSMay of
+ Nothing -> pure NoneV
+ Just elseS -> evalS elseS
+ else
+ go 0 (length filtered) Nothing filtered
+ where
+ goFilter :: Vector (Value m, Value m) -> Expr -> GingerT m (Vector (Value m, Value m))
+ goFilter pairs condE =
+ case V.uncons pairs of
+ Nothing ->
+ pure mempty
+ Just ((k, v), xs) -> do
+ keep <- scoped $ do
+ -- Bind key and value
+ maybe (pure ()) (\loopKey -> setVar loopKey k) loopKeyMay
+ setVar loopName v
+ asBool "loop condition" =<< evalE condE
+ rest <- goFilter xs condE
+ if keep then
+ pure $ V.cons (k, v) rest
+ else
+ pure rest
+
+ go :: Int -> Int -> Maybe (Value m) -> Vector (Value m, Value m) -> GingerT m (Value m)
+ go n num prevVal pairs = do
+ case V.uncons pairs of
+ Nothing -> pure NoneV
+ Just ((k, v), xs) -> do
+ (prevVal', body) <- scoped $ do
+ -- Bind key and value
+ maybe (pure ()) (\loopKey -> setVar loopKey k) loopKeyMay
+ setVar loopName v
+ env <- gets evalEnv
+ srcPosMay <- gets evalSourcePosition
+ let recurFuncID =
+ objectIDFromContext
+ "loop.recur" bodyS srcPosMay
+ let cycleFuncID =
+ objectIDFromContext
+ "loop.cycle" bodyS srcPosMay
+ setVar "loop" $
+ dictV
+ [ "index" .= (n + 1)
+ , "index0" .= n
+ , "revindex" .= (num - n)
+ , "revindex0" .= (num - n - 1)
+ , "first" .= (n == 0)
+ , "last" .= (n == num - 1)
+ , "length" .= num
+ , "cycle" .= cycleFunc cycleFuncID n
+ , "depth" .= (recursionLevel + 1)
+ , "depth0" .= recursionLevel
+ , "previtem" .= prevVal
+ , "nextitem" .= (snd <$> xs V.!? 0)
+ , "changed" .= changedFunc env v
+ , "__call__" .= if is recursivity then Just (recurFunc recurFuncID env) else Nothing
+ ]
+ body <- evalS bodyS
+ pure (Just v, body)
+
+ rest <- go (succ n) num prevVal' xs
+ concatValues body rest
+
+ changedFunc :: Env m -> Value m -> Value m
+ changedFunc env v = ProcedureV $ GingerProcedure env [("val", Just v)] $
+ EqualE (IndexE (VarE "loop") (StringLitE "previtem")) (VarE "val")
+
+ recurFunc :: ObjectID -> Env m -> Value m
+ recurFunc oid env =
+ ProcedureV .
+ NativeProcedure
+ oid
+ (Just ProcedureDoc
+ { procedureDocName = "loop.recur"
+ , procedureDocArgs = mempty
+ , procedureDocReturnType = Just $ TypeDocSingle "markup"
+ , procedureDocDescription =
+ "Recurse one level deeper into the iteree"
+ }
+ )
+ $ \args ctx -> do
+ case args of
+ [(_, iteree')] ->
+ runGingerT
+ (evalLoop
+ loopKeyMay
+ loopName
+ iteree'
+ loopCondMay
+ recursivity
+ bodyS
+ elseSMay
+ (succ recursionLevel))
+ ctx
+ env
+ [] -> pure . Left $
+ ArgumentError "loop()" "1" "argument" "end of arguments"
+ _ -> pure . Left $
+ ArgumentError "loop()" "2" "end of arguments" "argument"
+
+
+ cycleFunc :: ObjectID -> Int -> Value m
+ cycleFunc oid n =
+ ProcedureV .
+ NativeProcedure
+ oid
+ (Just ProcedureDoc
+ { procedureDocName = "loop.cycle"
+ , procedureDocArgs =
+ [ ArgumentDoc
+ "items"
+ (Just $ TypeDocSingle "list")
+ Nothing
+ ""
+ ]
+ , procedureDocReturnType = Just TypeDocAny
+ , procedureDocDescription =
+ "Cycle through 'items': on the n-th iteration of the loop, " <>
+ "cycle(items) will return items[n % length(items)]."
+ }
+ )
+ $ \args _ctx -> do
+ case args of
+ [(_, items)] ->
+ case items of
+ ListV [] ->
+ pure . Right $ NoneV
+ ListV xs -> do
+ let n' = n `mod` V.length xs
+ pure . Right . toValue $ xs V.!? n'
+ _ ->
+ pure . Right $ NoneV
+ _ -> pure . Left $
+ ArgumentError "cycle()" "1" "end of arguments" "argument"
+
+
+evalSs :: Monad m => [Statement] -> GingerT m (Value m)
+evalSs stmts = mapM evalS stmts >>= foldM concatValues NoneV
diff --git a/src/Language/Ginger/Interpret/Type.hs b/src/Language/Ginger/Interpret/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Interpret/Type.hs
@@ -0,0 +1,322 @@
+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Language.Ginger.Interpret.Type
+where
+
+import Language.Ginger.AST
+import Language.Ginger.RuntimeError
+import Language.Ginger.SourcePosition
+import Language.Ginger.Value
+
+import Control.Applicative ((<|>))
+import Control.Monad (forM)
+import Control.Monad.Except
+ ( ExceptT (..)
+ , MonadError (..)
+ , runExceptT
+ , throwError
+ )
+import Control.Monad.Reader
+ ( ReaderT
+ , MonadReader
+ , runReaderT
+ , asks
+ )
+import Control.Monad.State
+ ( StateT (..)
+ , MonadState (..)
+ , MonadTrans (..)
+ , evalStateT
+ , get
+ , gets
+ , modify
+ )
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+-- | The Ginger interpreter monad. Provides error reporting / handling via
+-- 'MonadError', an execution context ('Context'), and an evaluation state
+-- ('EvalState').
+newtype GingerT m a =
+ GingerT { unGingerT :: ReaderT (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a }
+ deriving (Functor, Applicative, Monad)
+
+-- | Evaluation state. This keeps track of variables in scope, as well as
+-- loaded templates and blocks, and the current source position.
+data EvalState m =
+ EvalState
+ { evalEnv :: !(Env m)
+ , evalMutables :: !(Map RefID (Value m))
+ , evalNextRefID :: !RefID
+ , evalLoadedTemplates :: !(Map Text CachedTemplate)
+ , evalBlocks :: !(Map Identifier LoadedBlock)
+ , evalSourcePosition :: !(Maybe SourcePosition)
+ }
+
+data LoadedBlock =
+ LoadedBlock
+ { loadedBlock :: !Block
+ , loadedBlockParent :: !(Maybe LoadedBlock)
+ }
+ deriving (Show)
+
+instance Semigroup (EvalState m) where
+ a <> b =
+ EvalState
+ { evalEnv = evalEnv a <> evalEnv b
+ , evalMutables = evalMutables a <> evalMutables b
+ , evalNextRefID = max (evalNextRefID a) (evalNextRefID b)
+ , evalLoadedTemplates = evalLoadedTemplates a <> evalLoadedTemplates b
+ , evalBlocks = evalBlocks a <> evalBlocks b
+ , evalSourcePosition = evalSourcePosition a <|> evalSourcePosition b
+ }
+
+data CachedTemplate
+ = CachedTemplate !LoadedTemplate
+ | MissingTemplate
+
+data LoadedTemplate =
+ LoadedTemplate
+ { loadedTemplateParent :: !(Maybe LoadedTemplate)
+ , loadedTemplateBody :: !Statement
+ }
+
+runGingerT :: Monad m => GingerT m a -> Context m -> Env m -> m (Either RuntimeError a)
+runGingerT g ctx env =
+ runExceptT
+ (evalStateT
+ (runReaderT (unGingerT g) ctx)
+ (EvalState env { envRootMay = Just env } mempty (RefID 0) mempty mempty Nothing)
+ )
+
+decorateError :: Monad m
+ => SourcePosition
+ -> RuntimeError
+ -> GingerT m a
+decorateError pos err =
+ throwError (PositionedError pos err)
+
+deriving instance Monad m => MonadState (EvalState m) (GingerT m)
+deriving instance Monad m => MonadReader (Context m) (GingerT m)
+deriving instance Monad m => MonadError RuntimeError (GingerT m)
+
+instance MonadTrans GingerT where
+ lift = GingerT . lift . lift . lift
+
+lookupVar :: Monad m
+ => Identifier
+ -> GingerT m (Value m)
+lookupVar name =
+ lookupVarMaybe name >>= maybe (throwError $ NotInScopeError (identifierName name)) pure
+
+lookupVarMaybe :: Monad m
+ => Identifier
+ -> GingerT m (Maybe (Value m))
+lookupVarMaybe name = do
+ valEnv <- gets (Map.lookup name . envVars . evalEnv)
+ case valEnv of
+ Nothing ->
+ asks (Map.lookup name . contextVars)
+ Just val ->
+ pure $ Just val
+
+modifyEnv :: Monad m
+ => (Env m -> Env m)
+ -> GingerT m ()
+modifyEnv f =
+ modify (\s -> s { evalEnv = f (evalEnv s) })
+
+setVar :: Monad m
+ => Identifier
+ -> Value m
+ -> GingerT m ()
+setVar name val =
+ modifyEnv (\e -> e { envVars = Map.insert name val $ envVars e })
+
+setVars :: Monad m
+ => Map Identifier (Value m)
+ -> GingerT m ()
+setVars vars = modifyEnv (\e -> e { envVars = vars <> envVars e })
+
+setMutable :: forall m. Monad m
+ => Identifier
+ -> Identifier
+ -> Value m
+ -> GingerT m ()
+setMutable name attr val = do
+ varVal <- lookupVar name
+ refID <- case varVal of
+ MutableRefV i -> pure i
+ x -> throwError $ TagError (identifierName name) "mutable ref" (tagNameOf x)
+ modifyMutable refID go
+ where
+ go :: Value m -> GingerT m (Value m)
+ go (DictV m) = pure (DictV $ Map.insert (toScalar attr) val m)
+ go x = throwError $
+ TagError
+ (identifierName name)
+ "dict"
+ (tagNameOf x)
+
+setBlock :: Monad m
+ => Identifier
+ -> Block
+ -> GingerT m LoadedBlock
+setBlock name block = do
+ mparent <- gets (Map.lookup name . evalBlocks)
+ let lblock = LoadedBlock block Nothing
+ lblock' = maybe lblock (appendLoadedBlock lblock) mparent
+ modify (\s -> s { evalBlocks = Map.insert name lblock' (evalBlocks s) })
+ pure lblock'
+
+allocMutable :: (Monad m, MonadTrans t, MonadState (EvalState m) (t m))
+ => Value m
+ -> t m RefID
+allocMutable val = do
+ refID <- gets evalNextRefID
+ modify (\s ->
+ s { evalNextRefID = succ (evalNextRefID s)
+ , evalMutables = Map.insert refID val (evalMutables s)
+ })
+ pure refID
+
+assignMutable :: Monad m
+ => RefID
+ -> Value m
+ -> GingerT m ()
+assignMutable refID val =
+ modify (\s -> s { evalMutables = Map.insert refID val (evalMutables s) })
+
+modifyMutable :: Monad m
+ => RefID
+ -> (Value m -> GingerT m (Value m))
+ -> GingerT m ()
+modifyMutable refID f = do
+ mval <- derefMutable refID
+ mval' <- f mval
+ modify (\s -> s { evalMutables = Map.insert refID mval' (evalMutables s) })
+
+derefMutableMaybe :: Monad m
+ => RefID
+ -> GingerT m (Maybe (Value m))
+derefMutableMaybe refID =
+ gets (Map.lookup refID . evalMutables)
+
+derefMutable :: Monad m
+ => RefID
+ -> GingerT m (Value m)
+derefMutable refID =
+ derefMutableMaybe refID >>=
+ maybe (throwError $ NotInScopeError ("ref#" <> Text.show refID)) pure
+
+setSourcePosition :: Monad m
+ => SourcePosition
+ -> GingerT m ()
+setSourcePosition pos = do
+ modify (\s -> s { evalSourcePosition = Just pos })
+
+clearSourcePosition :: Monad m
+ => GingerT m ()
+clearSourcePosition =
+ modify (\s -> s { evalSourcePosition = Nothing })
+
+
+appendLoadedBlock :: LoadedBlock -> LoadedBlock -> LoadedBlock
+appendLoadedBlock t h =
+ case loadedBlockParent h of
+ Nothing -> h { loadedBlockParent = Just t }
+ Just p -> h { loadedBlockParent = Just (appendLoadedBlock t p) }
+
+getBlock :: Monad m
+ => Identifier
+ -> GingerT m (Maybe LoadedBlock)
+getBlock name = gets (Map.lookup name . evalBlocks)
+
+scoped :: Monad m
+ => GingerT m a
+ -> GingerT m a
+scoped action = do
+ s <- get
+ retval <- action
+ modifyEnv $ const (evalEnv s)
+ return retval
+
+-- | Run a 'GingerT' action in a fresh environment; however, any globals set
+-- by the invoked action will be ported back to the calling environment.
+withoutContext :: Monad m
+ => GingerT m a
+ -> GingerT m a
+withoutContext action = do
+ e <- gets evalEnv
+ modifyEnv envRoot
+ retval <- action
+ e' <- gets evalEnv
+ modifyEnv $ const (e' <> e)
+ return retval
+
+withEnv :: Monad m
+ => Env m
+ -> GingerT m a
+ -> GingerT m a
+withEnv env action = do
+ s <- get
+ modifyEnv (const env)
+ retval <- action
+ modifyEnv (const $ evalEnv s)
+ return retval
+
+bind :: Monad m => (Env m -> a) -> GingerT m a
+bind f = f <$> gets evalEnv
+
+-- | Lift a dictionary value into the current scope, such that dictionary keys
+-- become variables bound to the respective values in the dictionary.
+scopify :: forall m. Monad m
+ => Value m
+ -> GingerT m ()
+scopify = \case
+ DictV items -> do
+ items' <- forM (Map.toList items) $ \(k, v) -> do
+ k' <- scalarToIdentifier k
+ pure (k', v)
+ setVars $ Map.fromList items'
+ x -> throwError $ TagError "liftScope" "dict" (tagNameOf x)
+ where
+ scalarToIdentifier :: Scalar -> GingerT m Identifier
+ scalarToIdentifier (StringScalar txt) = pure $ Identifier txt
+ scalarToIdentifier x = throwError $ TagError "liftScope" "string" (tagNameOf $ ScalarV x)
+
+withJinjaFilters :: (Monad m)
+ => GingerT m a
+ -> GingerT m a
+withJinjaFilters = withJinjaKey "filters"
+
+withJinjaTests :: (Monad m)
+ => GingerT m a
+ -> GingerT m a
+withJinjaTests = withJinjaKey "tests"
+
+withJinjaKey :: (Monad m)
+ => Identifier
+ -> GingerT m a
+ -> GingerT m a
+withJinjaKey key inner =
+ scoped $ do
+ jinjaFilters <-
+ fmap (fromMaybe NoneV . Map.lookup (toScalar key)) $
+ lookupVar "__jinja__" >>= eitherExceptM . asDictVal
+ scopify jinjaFilters
+ inner
+
diff --git a/src/Language/Ginger/Parse.hs b/src/Language/Ginger/Parse.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Parse.hs
@@ -0,0 +1,816 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+module Language.Ginger.Parse
+( P
+, expr
+, statement
+, template
+, parseGinger
+, parseGingerFile
+, parseGingerWith
+, parseGingerFileWith
+, POptions (..)
+, defPOptions
+, BlockTrimming (..)
+, BlockStripping (..)
+, simplifyS
+)
+where
+
+import Control.Monad (void, when, replicateM)
+import Control.Monad.Reader (Reader, runReader, ask, asks)
+import Data.Char (isAlphaNum, isAlpha, isDigit, isSpace, chr)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Void (Void)
+import Text.Megaparsec as Megaparsec
+import Text.Megaparsec.Char
+
+import Language.Ginger.AST as AST
+import Language.Ginger.SourcePosition as AST
+
+--------------------------------------------------------------------------------
+-- Parser Type
+--------------------------------------------------------------------------------
+
+type P = ParsecT Void Text (Reader POptions)
+
+data BlockTrimming
+ = NoTrimBlocks
+ | TrimBlocks
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+data BlockStripping
+ = NoStripBlocks
+ | StripBlocks
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+data PolicyOverride
+ = Default
+ | Never
+ | Always
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+class OverridablePolicy a where
+ override :: PolicyOverride -> a -> a
+
+instance OverridablePolicy BlockTrimming where
+ override Default a = a
+ override Never _ = NoTrimBlocks
+ override Always _ = TrimBlocks
+
+instance OverridablePolicy BlockStripping where
+ override Default a = a
+ override Never _ = NoStripBlocks
+ override Always _ = StripBlocks
+
+data POptions =
+ POptions
+ { pstateTrimBlocks :: !BlockTrimming
+ , pstateStripBlocks :: !BlockStripping
+ }
+ deriving (Show, Read, Eq)
+
+instance OverridablePolicy POptions where
+ override o (POptions tr st) = POptions (override o tr) (override o st)
+
+
+defPOptions :: POptions
+defPOptions = POptions
+ { pstateTrimBlocks = TrimBlocks
+ , pstateStripBlocks = NoStripBlocks
+ }
+
+--------------------------------------------------------------------------------
+-- Running Parsers
+--------------------------------------------------------------------------------
+
+parseGinger :: P a -> FilePath -> Text -> Either String a
+parseGinger = parseGingerWith defPOptions
+
+parseGingerWith :: POptions -> P a -> FilePath -> Text -> Either String a
+parseGingerWith options p filename input =
+ mapLeft errorBundlePretty $ runReader (runParserT p filename input) options
+
+parseGingerFile :: P a -> FilePath -> IO (Either String a)
+parseGingerFile = parseGingerFileWith defPOptions
+
+parseGingerFileWith :: POptions -> P a -> FilePath -> IO (Either String a)
+parseGingerFileWith options p filename = do
+ input <- Text.readFile filename
+ return $ mapLeft errorBundlePretty $ runReader (runParserT p filename input) options
+
+mapLeft :: (a -> b) -> Either a c -> Either b c
+mapLeft f (Left x) = Left (f x)
+mapLeft _ (Right x) = Right x
+
+--------------------------------------------------------------------------------
+-- Primitives etc.
+--------------------------------------------------------------------------------
+
+positioned :: (SourcePosition -> a -> b) -> P a -> P b
+positioned setPos inner = do
+ pos <- convertSourcePos <$> getSourcePos
+ setPos pos <$> inner
+
+convertSourcePos :: SourcePos -> SourcePosition
+convertSourcePos sp =
+ SourcePosition
+ { AST.sourceFile = Text.pack $ Megaparsec.sourceName sp
+ , AST.sourceLine = unPos $ Megaparsec.sourceLine sp
+ , AST.sourceColumn = unPos $ Megaparsec.sourceColumn sp
+ }
+
+identifierChar :: P Char
+identifierChar = satisfy isIdentifierChar
+
+isIdentifierChar :: Char -> Bool
+isIdentifierChar c =
+ isAlphaNum c || c == '_'
+
+identifierInitialChar :: P Char
+identifierInitialChar = satisfy isIdentifierInitialChar
+
+isIdentifierInitialChar :: Char -> Bool
+isIdentifierInitialChar c =
+ isAlpha c || c == '_'
+
+isOperatorChar :: Char -> Bool
+isOperatorChar c =
+ c `elem` ("&|%^*+-/~.=!,(){}[]" :: [Char])
+
+operatorChar :: P Char
+operatorChar = satisfy isOperatorChar
+
+operator :: Text -> P ()
+operator op = try $ do
+ void $ chunk op
+ notFollowedBy operatorChar
+ space
+
+keyword :: Text -> P ()
+keyword kw = try $ do
+ void $ chunk kw
+ notFollowedBy identifierChar
+ space
+
+identifierRaw :: P Text
+identifierRaw = do
+ Text.cons <$> identifierInitialChar
+ <*> takeWhileP (Just "identifier char") isIdentifierChar
+ <* space
+
+identifier :: P Identifier
+identifier = Identifier <$> identifierRaw
+
+stringLit :: P Text
+stringLit =
+ choice
+ [ char q *> (Text.pack . catMaybes <$> many (stringLitChar q)) <* char q <* space
+ | q <- ['"', '\'']
+ ]
+
+stringLitChar :: Char -> P (Maybe Char)
+stringLitChar q =
+ escapedStringLitChar <|> (Just <$> plainStringLitChar q)
+
+escapedStringLitChar :: P (Maybe Char)
+escapedStringLitChar = do
+ void $ char '\\'
+ c <- satisfy (const True)
+ case c of
+ '0' -> pure . Just $ '\0'
+ 'a' -> pure . Just $ '\a'
+ 'b' -> pure . Just $ '\b'
+ 'f' -> pure . Just $ '\f'
+ 'n' -> pure . Just $ '\n'
+ 'r' -> pure . Just $ '\r'
+ 't' -> pure . Just $ '\t'
+ 'v' -> pure . Just $ '\v'
+ '"' -> pure . Just $ '"'
+ '\'' -> pure . Just $ '\''
+ '\\' -> pure . Just $ '\\'
+ '&' -> pure Nothing
+ 'x' -> hexEscape 2
+ 'u' -> hexEscape 4
+ 'U' -> hexEscape 8
+ t -> unexpected (Tokens $ t :| [])
+ where
+ hexEscape n = do
+ ns <- replicateM n hexChar
+ pure . Just . chr $ read ("0x" ++ ns)
+
+hexChar :: P Char
+hexChar = satisfy isHexChar
+
+isHexChar :: Char -> Bool
+isHexChar x =
+ isDigit x ||
+ (x >= 'a' && x <= 'z') ||
+ (x >= 'A' && x <= 'Z')
+
+plainStringLitChar :: Char -> P Char
+plainStringLitChar q = satisfy (`notElem` ['\\', q])
+
+intLit :: P Integer
+intLit = do
+ read <$> (intDigits <* space)
+
+intDigits :: P String
+intDigits = try $ do
+ sign <- try $ (option "" $ "-" <$ char '-')
+ str <- some digit
+ pure (sign ++ str)
+
+floatLit :: P Double
+floatLit = do
+ m <- do
+ sign <- try $ (option "" $ "-" <$ char '-')
+ intPart <- many digit
+ void $ char '.'
+ fracPart <- many digit
+ when (null intPart && null fracPart)
+ (unexpected $ Label $ 'd' :| "ot-only float")
+ pure $ sign ++
+ (if null intPart then "0" else intPart) ++
+ "." ++
+ (if null fracPart then "0" else fracPart)
+ e <- option "" $ do
+ void $ char 'E' <|> char 'e'
+ ('e' :) <$> intDigits
+ space
+ pure . read $ m ++ e
+
+
+digit :: P Char
+digit = satisfy isDigit
+
+equals :: P ()
+equals = char '=' *> space
+
+comma :: P ()
+comma = char ',' *> space
+
+colon :: P ()
+colon = char ':' *> space
+
+parenthesized :: P a -> P a
+parenthesized = betweenT "(" ")"
+
+bracketed :: P a -> P a
+bracketed = betweenT "[" "]"
+
+braced :: P a -> P a
+braced = betweenT "{" "}"
+
+betweenT :: Text -> Text -> P c -> P c
+betweenT o c =
+ between (chunk o *> space) (chunk c *> space)
+
+--------------------------------------------------------------------------------
+-- Argument lists
+--------------------------------------------------------------------------------
+
+callArgs :: P ([Expr], [(Identifier, Expr)])
+callArgs = do
+ args <- parenthesized $ argPair `sepBy` comma
+ let posArgs = [ e | (Nothing, e) <- args ]
+ kwArgs = [ (k, e) | (Just k, e) <- args ]
+ pure (posArgs, kwArgs)
+
+argPair :: P (Maybe Identifier, Expr)
+argPair = try kwArgPair <|> ((Nothing ,) <$> expr)
+
+kwArgPair :: P (Maybe Identifier, Expr)
+kwArgPair =
+ (,) <$> (Just <$> identifier) <*> (equals *> expr)
+
+argsSig :: P [(Identifier, Maybe Expr)]
+argsSig = parenthesized $ argSig `sepBy` comma
+
+argSig :: P (Identifier, Maybe Expr)
+argSig =
+ (,) <$> identifier
+ <*> optional (chunk "=" *> space *> expr)
+
+
+--------------------------------------------------------------------------------
+-- Expression parsers
+--------------------------------------------------------------------------------
+
+expr :: P Expr
+expr = positioned PositionedE ternaryExpr "expression"
+
+ternaryExpr :: P Expr
+ternaryExpr = do
+ lhs <- booleanExpr
+ option lhs $ exprTail lhs
+ where
+ exprTail lhs = try $ do
+ keyword "if"
+ cond <- booleanExpr
+ keyword "else"
+ rhs <- ternaryExpr
+ pure $ TernaryE cond lhs rhs
+
+binaryExpr :: P BinaryOperator -> P Expr -> P Expr
+binaryExpr op sub = do
+ lhs <- sub
+ exprTail lhs
+ where
+ exprTail lhs = choice
+ [ do
+ o <- op
+ rhs <- sub
+ exprTail (BinaryE o lhs rhs)
+ , pure lhs
+ ]
+
+booleanExpr :: P Expr
+booleanExpr = binaryExpr booleanOp unaryNotExpr
+
+booleanOp :: P BinaryOperator
+booleanOp = choice
+ [ BinopAnd <$ keyword "and"
+ , BinopOr <$ keyword "or"
+ ]
+
+unaryNotExpr :: P Expr
+unaryNotExpr =
+ (keyword "not" *> (NotE <$> unaryNotExpr))
+ <|>
+ comparativeExpr
+
+comparativeExpr :: P Expr
+comparativeExpr = binaryExpr comparativeOp testExpr
+
+comparativeOp :: P BinaryOperator
+comparativeOp = choice
+ [ BinopEqual <$ operator "=="
+ , BinopNotEqual <$ operator "!="
+ , BinopGT <$ operator ">"
+ , BinopGTE <$ operator ">="
+ , BinopLT <$ operator "<"
+ , BinopLTE <$ operator "<="
+ , BinopIn <$ keyword "in"
+ ]
+
+testExpr :: P Expr
+testExpr = do
+ lhs <- sub
+ option lhs $ exprTail lhs
+ where
+ sub = concatExpr
+
+ exprTail lhs = do
+ keyword "is"
+ wrapper <- option id $ NotE <$ keyword "not"
+ test <- VarE <$> identifier
+ (posArgs, kwArgs) <- option ([], []) (try callArgs <|> try soloArg)
+ pure . wrapper $ IsE lhs test posArgs kwArgs
+
+soloArg :: P ([Expr], [(Identifier, Expr)])
+soloArg = do
+ notFollowedBy $ choice
+ [ keyword "and"
+ , keyword "or"
+ , keyword "in"
+ , keyword "is"
+ , keyword "not"
+ ]
+ arg <- expr
+ pure ([arg], [])
+
+concatExpr :: P Expr
+concatExpr = binaryExpr concatOp additiveExpr
+
+concatOp :: P BinaryOperator
+concatOp = BinopConcat <$ operator "~"
+
+additiveExpr :: P Expr
+additiveExpr = binaryExpr additiveOp multiplicativeExpr
+
+additiveOp :: P BinaryOperator
+additiveOp = choice
+ [ BinopPlus <$ operator "+"
+ , BinopMinus <$ operator "-"
+ ]
+
+multiplicativeExpr :: P Expr
+multiplicativeExpr = binaryExpr multiplicativeOp powerExpr
+
+multiplicativeOp :: P BinaryOperator
+multiplicativeOp = choice
+ [ BinopIntDiv <$ operator "//"
+ , BinopDiv <$ operator "/"
+ , BinopMod <$ operator "%"
+ , BinopMul <$ operator "*"
+ ]
+
+powerExpr :: P Expr
+powerExpr = binaryExpr powerOp memberAccessExpr
+
+powerOp :: P BinaryOperator
+powerOp = BinopPower <$ operator "**"
+
+memberAccessExpr :: P Expr
+memberAccessExpr = do
+ lhs <- simpleExpr
+ exprTail lhs
+ where
+ exprTail lhs = dotTail lhs
+ <|> bracketsTail lhs
+ <|> callTail lhs
+ <|> filterTail lhs
+ <|> pure lhs
+
+ dotTail lhs = do
+ chunk "." *> space
+ selector <- identifier
+ exprTail (DotE lhs selector)
+
+ sliceCont lhs op1May = do
+ try $ chunk ":" *> space
+ op2May <- optional expr
+ pure $ SliceE lhs op1May op2May
+
+ bracketsTail lhs = do
+ t <- bracketed $ do
+ op1May <- optional expr
+ case op1May of
+ Nothing ->
+ sliceCont lhs op1May
+ Just op1 -> do
+ choice
+ [ sliceCont lhs op1May
+ , pure $ IndexE lhs op1
+ ]
+ exprTail t
+
+ callTail lhs = do
+ (posArgs, kwArgs) <- callArgs
+ exprTail (CallE lhs posArgs kwArgs)
+
+ filterTail lhs = do
+ chunk "|" *> space
+ callable <- simpleExpr
+ (posArgs, kwArgs) <- option ([], []) $ callArgs
+ exprTail (FilterE lhs callable posArgs kwArgs)
+
+list :: P (Vector Expr)
+list = V.fromList <$> bracketed (expr `sepBy` comma)
+
+dict :: P [(Expr, Expr)]
+dict = braced (dictPair `sepBy` comma)
+
+dictPair :: P (Expr, Expr)
+dictPair =
+ (,) <$> expr <*> (colon *> expr)
+
+simpleExpr :: P Expr
+simpleExpr = choice
+ [ parenthesized expr
+ , StringLitE <$> stringLit
+ , ListE <$> list
+ , DictE <$> dict
+ , FloatLitE <$> try floatLit
+ , IntLitE <$> try intLit
+ , try (operator "-") *> space *> (NegateE <$> (parenthesized expr <|> (VarE <$> identifier)))
+ , BoolE True <$ (keyword "true" <|> keyword "True")
+ , BoolE False <$ (keyword "false" <|> keyword "False")
+ , NoneE <$ (keyword "none" <|> keyword "None")
+ , VarE <$> identifier
+ ]
+
+--------------------------------------------------------------------------------
+-- Statement-level tokens
+--------------------------------------------------------------------------------
+
+overrideToken :: P PolicyOverride
+overrideToken =
+ choice
+ [ Always <$ chunk "-"
+ , Never <$ chunk "+"
+ , pure Default
+ ]
+
+openWithOverride :: Text -> P ()
+openWithOverride base = do
+ policy <- ask
+ let defLeader = case pstateStripBlocks policy of
+ StripBlocks -> inlineSpace
+ NoStripBlocks -> pure ()
+ void $ choice
+ [ try $ inlineSpace *> chunk base *> chunk "-" <* notFollowedBy operatorChar
+ , try $ chunk base *> chunk "+" <* notFollowedBy operatorChar
+ , try $ chunk base <* notFollowedBy operatorChar
+ , try $ defLeader *> chunk base <* notFollowedBy operatorChar
+ ]
+ space
+
+inlineSpace :: P ()
+inlineSpace =
+ void $
+ takeWhileP
+ (Just "non-newline whitespace")
+ (\c -> isSpace c && c `notElem` ['\r', '\n'])
+
+anyNewline :: P Text
+anyNewline =
+ choice
+ [ chunk "\r\n"
+ , chunk "\n"
+ , chunk "\r"
+ ]
+
+closeWithOverride :: Text -> P ()
+closeWithOverride base = do
+ ovr <- try $ overrideToken <* chunk base
+ policy <- asks (override ovr)
+ when (pstateTrimBlocks policy == TrimBlocks) $
+ void . optional . try $ inlineSpace *> (void anyNewline <|> eof)
+
+openComment :: P ()
+openComment = openWithOverride "{#"
+
+closeComment :: P ()
+closeComment = closeWithOverride "#}"
+
+openInterpolation :: P ()
+openInterpolation = openWithOverride "{{"
+
+closeInterpolation :: P ()
+closeInterpolation = closeWithOverride "}}"
+
+openFlow :: P ()
+openFlow = openWithOverride "{%"
+
+closeFlow :: P ()
+closeFlow = closeWithOverride "%}"
+
+
+--------------------------------------------------------------------------------
+-- Statement parsers
+--------------------------------------------------------------------------------
+
+template :: P Template
+template = do
+ Template <$> extends <*> statement
+
+extends :: P (Maybe Text)
+extends =
+ optional . flow "extends" $ do
+ stringLit <* space
+
+simplifyS :: Statement -> Statement
+simplifyS = traverseS simplifyOne id
+ where
+ simplifyOne (GroupS xs) = wrap xs
+ simplifyOne s = s
+
+statement :: P Statement
+statement =
+ wrap <$> many singleStatement
+
+joinImmediates :: [Statement] -> [Statement]
+joinImmediates (ImmediateS a : ImmediateS b : xs) =
+ joinImmediates (ImmediateS (a <> b) : xs)
+joinImmediates (PositionedS pos (ImmediateS a) : PositionedS _ (ImmediateS b) : xs) =
+ joinImmediates (PositionedS pos (ImmediateS (a <> b)) : xs)
+joinImmediates (PositionedS pos (ImmediateS a) : ImmediateS b : xs) =
+ joinImmediates (PositionedS pos (ImmediateS (a <> b)) : xs)
+joinImmediates (x:xs) = x : joinImmediates xs
+joinImmediates [] = []
+
+wrap :: [Statement] -> Statement
+wrap [] = ImmediateS mempty
+wrap [x] = x
+wrap xs = GroupS (joinImmediates xs)
+
+singleStatement :: P Statement
+singleStatement =
+ positioned PositionedS $
+ choice
+ [ commentStatement
+ , interpolationStatement
+ , controlStatement
+ , immediateStatement
+ ]
+
+immediateStatement :: P Statement
+immediateStatement =
+ ImmediateS . Encoded <$>
+ choice
+ [ anyNewline
+ , fmap mconcat . some $
+ notFollowedBy (openComment <|> openInterpolation <|> openFlow) >> chunk "{"
+ <|>
+ takeWhile1P Nothing (`notElem` ['{', '\n', '\r'])
+ ]
+
+commentStatement :: P Statement
+commentStatement =
+ between openComment closeComment $
+ CommentS . Text.strip . Text.pack <$> many (notFollowedBy closeComment *> anySingle)
+
+interpolationStatement :: P Statement
+interpolationStatement =
+ between openInterpolation closeInterpolation $
+ InterpolationS <$> expr
+
+controlStatement :: P Statement
+controlStatement =
+ choice
+ [ ifStatement
+ , forStatement
+ , macroStatement
+ , callStatement
+ , filterStatement
+ , setStatement
+ , setBlockStatement
+ , includeStatement
+ , importStatement
+ , blockStatement
+ , withStatement
+ ]
+
+flow :: Text -> P a -> P a
+flow kw inner = do
+ try (openFlow >> keyword kw)
+ inner <* closeFlow
+
+flow_ :: Text -> P ()
+flow_ kw = flow kw nop
+
+withFlow :: Text -> P a -> P b -> (a -> b -> c) -> P c
+withFlow kw header body combine =
+ combine <$> flow kw header <*> body <* flow_ ("end" <> kw)
+
+nop :: P ()
+nop = pure ()
+
+ifStatement :: P Statement
+ifStatement = do
+ withFlow "if" expr body makeIf
+ where
+ body = do
+ yes <- statement
+ noMay <- optional $ flow_ "else" *> statement
+ pure (yes, noMay)
+ makeIf cond (yes, noMay) = IfS cond yes noMay
+
+forStatement :: P Statement
+forStatement = do
+ withFlow "for" forHeader forBody makeFor
+ where
+ forHeader = do
+ (keyMay, val) <- do
+ a' <- identifier
+ bMay' <- optional $ comma *> identifier
+ pure $ case (a', bMay') of
+ (a, Just b) -> (Just a, b)
+ (a, Nothing) -> (Nothing, a)
+ keyword "in"
+ iteree <- expr
+ filterMay <- optional $ keyword "if" *> expr
+ recursivity <- option NotRecursive $ Recursive <$ keyword "recursive"
+ pure (keyMay, val, iteree, filterMay, recursivity)
+ forBody = do
+ body <- statement
+ elseMay <- optional $ flow_ "else" *> statement
+ pure (body, elseMay)
+ makeFor (keyMay, val, iteree, filterMay, recursivity) (body, elseMay) =
+ ForS keyMay val iteree filterMay recursivity body elseMay
+
+macroStatement :: P Statement
+macroStatement = do
+ withFlow "macro" macroHeader macroBody makeMacro
+ where
+ macroHeader :: P (Identifier, [MacroArg])
+ macroHeader =
+ (,) <$> identifier <*> option [] argsSig
+ macroBody =
+ statement
+ makeMacro :: (Identifier, [MacroArg]) -> Statement -> Statement
+ makeMacro (name, args) body = MacroS name args body
+
+callStatement :: P Statement
+callStatement = do
+ withFlow "call" callHeader callBody makeCall
+ where
+ callHeader = do
+ (,) <$> identifier <*> callArgs
+ callBody = statement
+ makeCall (callee, (args, kwargs)) body = CallS callee args kwargs body
+
+filterStatement :: P Statement
+filterStatement = do
+ withFlow "filter" filterHeader filterBody makeFilter
+ where
+ filterHeader = do
+ (,) <$> identifier <*> callArgs
+ filterBody = statement
+ makeFilter (filteree, (args, kwargs)) body = FilterS filteree args kwargs body
+
+setPair :: P (Identifier, Expr)
+setPair = (,) <$> identifier <* chunk "=" <* space <*> expr
+
+setTargetPair :: P (SetTarget, Expr)
+setTargetPair = (,) <$> setTarget <* chunk "=" <* space <*> expr
+
+setTarget :: P SetTarget
+setTarget = do
+ leader <- identifier
+ selectorMay <- optional $ chunk "." *> identifier
+ pure $ case selectorMay of
+ Nothing -> SetVar leader
+ Just selector -> SetMutable leader selector
+
+setStatement :: P Statement
+setStatement = try $ do
+ flow "set" $ uncurry SetS <$> setTargetPair
+
+setBlockStatement :: P Statement
+setBlockStatement = do
+ withFlow "set" setBlockHeader setBlockBody makeSetBlock
+ where
+ setBlockHeader = (,) <$> setTarget <*> optional (chunk "|" *> space *> expr)
+ setBlockBody = statement
+ makeSetBlock (name, filterMay) body =
+ SetBlockS name body filterMay
+
+includeStatement :: P Statement
+includeStatement =
+ flow "include" $
+ IncludeS
+ <$> expr
+ <*> option RequireMissing (IgnoreMissing <$ keyword "ignore" <* keyword "missing")
+ <*> option WithContext (choice
+ [ WithContext <$ keyword "with" <* keyword "context"
+ , WithoutContext <$ keyword "without" <* keyword "context"
+ ]
+ )
+
+importStatement :: P Statement
+importStatement =
+ wildcardImportStatement <|> explicitImportStatement
+
+wildcardImportStatement :: P Statement
+wildcardImportStatement =
+ flow "import" $
+ ImportS
+ <$> expr
+ <*> optional (keyword "as" *> identifier)
+ <*> pure Nothing
+ <*> option RequireMissing (IgnoreMissing <$ keyword "ignore" <* keyword "missing")
+ <*> option WithoutContext (choice
+ [ WithContext <$ keyword "with" <* keyword "context"
+ , WithoutContext <$ keyword "without" <* keyword "context"
+ ]
+ )
+
+explicitImportStatement :: P Statement
+explicitImportStatement =
+ flow "from" $
+ ImportS
+ <$> expr
+ <*> optional (keyword "as" *> identifier)
+ <* keyword "import"
+ <*> (Just <$> do
+ notFollowedBy (choice $ map keyword ["ignore", "with", "without"])
+ importPair `sepBy` comma
+ )
+ <*> option RequireMissing (IgnoreMissing <$ keyword "ignore" <* keyword "missing")
+ <*> option WithoutContext (choice
+ [ WithContext <$ keyword "with" <* keyword "context"
+ , WithoutContext <$ keyword "without" <* keyword "context"
+ ]
+ )
+
+importPair :: P (Identifier, Maybe Identifier)
+importPair = (,) <$> identifier <*> optional (keyword "as" *> identifier)
+
+withStatement :: P Statement
+withStatement = do
+ withFlow "with" withHeader withBody makeWith
+ where
+ withHeader = setPair `sepBy` comma
+ withBody = statement
+ makeWith = WithS
+
+blockStatement :: P Statement
+blockStatement = do
+ (name, scopedness, requiredness) <- flow "block" $
+ (,,) <$> identifier
+ <*> (option NotScoped $ Scoped <$ keyword "scoped")
+ <*> (option Optional $ Required <$ keyword "required")
+ body <- statement
+ void $ flow "endblock" (optional $ keyword (identifierName name))
+ pure $ BlockS name (Block body scopedness requiredness)
diff --git a/src/Language/Ginger/Render.hs b/src/Language/Ginger/Render.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Render.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Language.Ginger.Render
+where
+
+import Language.Ginger.AST
+import Language.Ginger.Value
+
+import Data.Bool (bool)
+import Data.Char (isControl, ord)
+import Data.List (intersperse)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LText
+import Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as Builder
+import qualified Data.Vector as V
+import Text.Printf (printf)
+import qualified Data.Map.Strict as Map
+
+class RenderSyntax a where
+ renderSyntax :: a -> Builder
+
+renderSyntaxLText :: RenderSyntax a => a -> LText.Text
+renderSyntaxLText = Builder.toLazyText . renderSyntax
+
+renderSyntaxText :: RenderSyntax a => a -> Text
+renderSyntaxText = LText.toStrict . renderSyntaxLText
+
+renderStringLit :: Text -> Builder
+renderStringLit str =
+ "\"" <> mconcat (map renderStringLitChar $ Text.unpack str) <> "\""
+
+renderStringLitChar :: Char -> Builder
+renderStringLitChar '\0' = "\\0"
+renderStringLitChar '\a' = "\\a"
+renderStringLitChar '\b' = "\\b"
+renderStringLitChar '\f' = "\\f"
+renderStringLitChar '\n' = "\\n"
+renderStringLitChar '\r' = "\\r"
+renderStringLitChar '\t' = "\\t"
+renderStringLitChar '\v' = "\\v"
+renderStringLitChar '"' = "\\\""
+renderStringLitChar '\'' = "\\'"
+renderStringLitChar '\\' = "\\\\"
+renderStringLitChar c
+ | isControl c || ord c >= 128
+ = renderUnicodeEscape c
+ | otherwise = Builder.fromString [c]
+
+renderUnicodeEscape :: Char -> Builder
+renderUnicodeEscape c =
+ let o = ord c
+ format = if o <= 0xFF then
+ "\\x%02x"
+ else if o <= 0xFFFF then
+ "\\u%04x"
+ else
+ "\\U%08x"
+ in
+ Builder.fromString $ printf format o
+
+valueToExpr :: Value m -> Expr
+valueToExpr (StringV v) = StringLitE v
+valueToExpr TrueV = TrueE
+valueToExpr FalseV = FalseE
+valueToExpr (IntV i) = IntLitE i
+valueToExpr (FloatV f) = FloatLitE f
+valueToExpr NoneV = NoneE
+valueToExpr (ScalarV s) = error $ "Not matched: scalar " ++ show s
+valueToExpr (ListV items) = ListE $ V.map valueToExpr items
+valueToExpr (DictV xs) =
+ DictE
+ [ (valueToExpr (ScalarV k), valueToExpr v)
+ | (k, v) <- Map.toAscList xs
+ ]
+valueToExpr (NativeV _) = StringLitE "<>"
+valueToExpr (ProcedureV _) = StringLitE "<>"
+valueToExpr (TestV _) = StringLitE "<>"
+valueToExpr (FilterV _) = StringLitE "<>"
+valueToExpr (MutableRefV (RefID i)) = StringLitE $ "< Text.show i <> ">>"
+
+instance RenderSyntax (Value m) where
+ renderSyntax = renderSyntax . valueToExpr
+
+instance RenderSyntax SetTarget where
+ renderSyntax (SetVar name) = renderSyntax name
+ renderSyntax (SetMutable name attr) =
+ renderSyntax name <> "." <> renderSyntax attr
+
+instance RenderSyntax Expr where
+ renderSyntax (PositionedE _ e) = renderSyntax e
+ renderSyntax NoneE = "none"
+ renderSyntax TrueE = "true"
+ renderSyntax FalseE = "false"
+ renderSyntax (StatementE (InterpolationS e)) =
+ renderSyntax e
+ renderSyntax (StatementE (IfS cond yes noMay)) =
+ renderSyntax (TernaryE cond (StatementE yes) (maybe NoneE StatementE noMay))
+ renderSyntax (StatementE (ImmediateS (Encoded txt))) =
+ renderSyntax (FilterE (StringLitE txt) (VarE "encode") [] [])
+ renderSyntax (StatementE x) =
+ error $ "Cannot render statement expression " ++ (LText.unpack . Builder.toLazyText $ renderSyntax x)
+ renderSyntax (StringLitE str) = renderStringLit str
+ renderSyntax (IntLitE i) = Builder.fromText $ Text.show i
+ renderSyntax (FloatLitE f) = Builder.fromText $ Text.show f
+ renderSyntax (ListE xs) =
+ "[" <> (mconcat . intersperse ", " . map renderSyntax . V.toList $ xs) <> "]"
+ renderSyntax (DictE xs) =
+ "{" <> (mconcat . intersperse ", " $ [ renderSyntax k <> ": " <> renderSyntax v | (k, v) <- xs ]) <> "}"
+ renderSyntax (NotE expr) =
+ "(not " <> renderSyntax expr <> ")"
+ renderSyntax (NegateE expr) =
+ "-" <> renderSyntax expr
+ renderSyntax (IndexE a b) =
+ renderSyntax a <> "[" <> renderSyntax b <> "]"
+ renderSyntax (BinaryE op a b) =
+ "(" <> renderSyntax a <> renderSyntax op <> renderSyntax b <> ")"
+ renderSyntax (DotE (VarE a) b) =
+ renderSyntax a <> "." <> renderSyntax b
+ renderSyntax (DotE a b) =
+ "(" <> renderSyntax a <> ")." <> renderSyntax b
+ renderSyntax (SliceE slicee start end) =
+ renderSyntax slicee <> "[" <>
+ maybe "" renderSyntax start <> ":" <>
+ maybe "" renderSyntax end <> "]"
+ renderSyntax (IsE scrutinee test args kwargs) =
+ "(" <> renderSyntax scrutinee <> " is " <> renderSyntax test <> renderArgs args kwargs <> ")"
+ renderSyntax (CallE callee args kwargs) =
+ "(" <> renderSyntax callee <> renderArgs args kwargs <> ")"
+ renderSyntax (FilterE arg0 f args kwargs) =
+ "(" <> renderSyntax arg0 <> "|" <> renderSyntax f <> renderArgs args kwargs <> ")"
+ renderSyntax (TernaryE c y n) =
+ "(" <> renderSyntax y <> " if " <> renderSyntax c <> " else " <> renderSyntax n <> ")"
+ renderSyntax (VarE ident) =
+ renderSyntax ident
+ renderSyntax BoolE {} = "BoolE ???"
+ renderSyntax UnaryE {} = "UnaryE ???"
+
+instance RenderSyntax Identifier where
+ renderSyntax (Identifier i) = Builder.fromText i
+
+instance RenderSyntax IncludeMissingPolicy where
+ renderSyntax RequireMissing = "require missing"
+ renderSyntax IgnoreMissing = "ignore missing"
+
+instance RenderSyntax IncludeContextPolicy where
+ renderSyntax WithContext = "with context"
+ renderSyntax WithoutContext = "without context"
+
+instance RenderSyntax Scoped where
+ renderSyntax Scoped = "scoped"
+ renderSyntax NotScoped = ""
+
+instance RenderSyntax Required where
+ renderSyntax Required = "required"
+ renderSyntax Optional = ""
+
+instance RenderSyntax BinaryOperator where
+ renderSyntax BinopPlus = " + "
+ renderSyntax BinopMinus = " - "
+ renderSyntax BinopDiv = " / "
+ renderSyntax BinopIntDiv = " // "
+ renderSyntax BinopMod = " % "
+ renderSyntax BinopMul = " * "
+ renderSyntax BinopPower = " ** "
+ renderSyntax BinopEqual = " == "
+ renderSyntax BinopNotEqual = " != "
+ renderSyntax BinopGT = " > "
+ renderSyntax BinopGTE = " >= "
+ renderSyntax BinopLT = " < "
+ renderSyntax BinopLTE = " <= "
+ renderSyntax BinopAnd = " and "
+ renderSyntax BinopOr = " or "
+ renderSyntax BinopIn = " in "
+ renderSyntax BinopIndex = " [] "
+ renderSyntax BinopConcat = " ~ "
+
+renderFlow :: Builder -> Builder
+renderFlow inner = "{% " <> inner <> " %}\n"
+
+-- | Most 'Encoded's can actually be converted as-is, but if there are any
+-- curly braces, we need to handle them specially.
+renderEncoded :: Encoded -> Builder
+renderEncoded (Encoded txt) =
+ Builder.fromText .
+ Text.replace "{{" "{{'{{'}}" $
+ Text.replace "{%" "{{'{%'}}" $
+ Text.replace "{#" "{{'{#'}}" $
+ txt
+
+instance RenderSyntax Statement where
+ renderSyntax (PositionedS _ s) = renderSyntax s
+ renderSyntax (ImmediateS e) = renderEncoded e
+ renderSyntax (InterpolationS e) = "{{ " <> renderSyntax e <> " }}"
+ renderSyntax (CommentS msg) = "{# " <> Builder.fromText msg <> " #}\n"
+ renderSyntax (ForS kMay v iteree condMay recursivity body elseBranchMay) =
+ renderFlow (
+ "for " <>
+ maybe "" (\k -> renderSyntax k <> ", ") kMay <>
+ renderSyntax v <>
+ " in " <>
+ renderSyntax iteree <>
+ maybe "" (\cond -> " if " <> renderSyntax cond) condMay <>
+ bool "" " recursive" (is recursivity)
+ ) <>
+ renderSyntax body <>
+ maybe "" (\elseBranch -> renderFlow "else" <> renderSyntax elseBranch) elseBranchMay <>
+ renderFlow "endfor"
+ renderSyntax (IfS cond yes noMay) =
+ renderFlow (
+ "if " <>
+ renderSyntax cond
+ ) <>
+ renderSyntax yes <>
+ maybe "" (\no -> renderFlow "else" <> renderSyntax no) noMay <>
+ renderFlow "endif"
+ renderSyntax (MacroS name args body) =
+ renderFlow (
+ "macro " <>
+ renderSyntax name <>
+ " " <>
+ renderArgSpec args
+ ) <>
+ renderSyntax body <>
+ renderFlow "endmacro"
+ renderSyntax (CallS name args kwargs body) =
+ renderFlow (
+ "call " <>
+ renderSyntax name <>
+ renderArgs args kwargs
+ ) <>
+ renderSyntax body <>
+ renderFlow "endcall"
+ renderSyntax (FilterS name args kwargs body) =
+ renderFlow (
+ "filter " <>
+ renderSyntax name <>
+ renderArgs args kwargs
+ ) <>
+ renderSyntax body <>
+ renderFlow "endfilter"
+ renderSyntax (SetS name val) =
+ renderFlow (
+ "set " <>
+ renderSyntax name <>
+ " = " <>
+ renderSyntax val
+ )
+ renderSyntax (SetBlockS name body filterMay) =
+ renderFlow (
+ "set " <>
+ renderSyntax name <>
+ maybe "" (\f -> "|" <> renderSyntax f) filterMay
+ ) <>
+ renderSyntax body <>
+ renderFlow "endset"
+ renderSyntax (IncludeS includee missingPolicy contextPolicy) =
+ renderFlow (
+ "include " <>
+ renderSyntax includee <>
+ " " <>
+ renderSyntax missingPolicy <>
+ " " <>
+ renderSyntax contextPolicy
+ )
+ renderSyntax (ImportS importee aliasMay Nothing missingPolicy contextPolicy) =
+ renderFlow (
+ "import " <>
+ renderSyntax importee <>
+ maybe "" (\alias -> " as " <> renderSyntax alias) aliasMay <>
+ renderSyntax missingPolicy <>
+ " " <>
+ renderSyntax contextPolicy
+ )
+ renderSyntax (ImportS importee aliasMay (Just imports) missingPolicy contextPolicy) =
+ renderFlow (
+ "from " <>
+ renderSyntax importee <>
+ maybe " " (\alias -> " as " <> renderSyntax alias) aliasMay <>
+ "import " <>
+ renderImports imports <>
+ " " <>
+ renderSyntax missingPolicy <>
+ " " <>
+ renderSyntax contextPolicy
+ )
+ renderSyntax (BlockS name (Block body scopedness requiredness)) =
+ renderFlow (
+ "block " <>
+ renderSyntax name <>
+ " " <>
+ renderSyntax scopedness <>
+ " " <>
+ renderSyntax requiredness
+ ) <>
+ renderSyntax body <>
+ renderFlow "endblock"
+ renderSyntax (WithS defs body) =
+ renderFlow (
+ "with " <>
+ renderWithDefs defs
+ ) <>
+ renderSyntax body <>
+ renderFlow "endwith"
+ renderSyntax (GroupS ss) =
+ mconcat . map renderSyntax $ ss
+
+renderImports :: [(Identifier, Maybe Identifier)] -> Builder
+renderImports = mconcat . intersperse ", " . map renderImport
+
+renderImport :: (Identifier, Maybe Identifier) -> Builder
+renderImport (i, Nothing) = renderSyntax i
+renderImport (i, Just a) = renderSyntax i <> " as " <> renderSyntax a
+
+renderWithDefs :: [(Identifier, Expr)] -> Builder
+renderWithDefs args =
+ mconcat . intersperse ", " $
+ [ renderSyntax k <> "=" <> renderSyntax v | (k, v) <- args ]
+
+renderArgs :: [Expr] -> [(Identifier, Expr)] -> Builder
+renderArgs args kwargs =
+ let allArgs = map (Nothing ,) args ++ [(Just k, v) | (k, v) <- kwargs]
+ in
+ "(" <>
+ (mconcat . intersperse ", " $
+ [ maybe "" (\k -> renderSyntax k <> "=") kMay <> renderSyntax v
+ | (kMay, v) <- allArgs
+ ]
+ ) <>
+ ")"
+
+renderArgSpec :: [(Identifier, Maybe Expr)] -> Builder
+renderArgSpec args =
+ "(" <>
+ (mconcat . intersperse ", " $
+ [ renderSyntax k <> maybe "" (\v -> "=" <> renderSyntax v) vMay
+ | (k, vMay) <- args
+ ]
+ ) <>
+ ")"
+
+instance RenderSyntax Template where
+ renderSyntax (Template parentMay body) =
+ maybe "" (renderFlow . ("extends " <>) . renderSyntax . StringLitE) parentMay <>
+ renderSyntax body
diff --git a/src/Language/Ginger/RuntimeError.hs b/src/Language/Ginger/RuntimeError.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/RuntimeError.hs
@@ -0,0 +1,76 @@
+module Language.Ginger.RuntimeError
+where
+
+import Data.Text (Text)
+import Control.Exception
+import Text.Printf
+
+import Language.Ginger.SourcePosition
+
+data RuntimeError
+ = ArgumentError
+ Text -- ^ Callee
+ Text -- ^ Argument (position or name)
+ Text -- ^ Expected argument
+ Text -- ^ Actual argument
+ | TagError
+ Text -- ^ Identifier / object / context
+ Text -- ^ Expected type(s)
+ Text -- ^ Actual type
+ | NonCallableObjectError
+ Text -- ^ Object that was attempted to be used as a callable
+ | NotInScopeError
+ Text -- ^ Identifier
+ | NotImplementedError
+ Text -- ^ The thing that isn't implemented
+ | NumericError
+ Text -- ^ Identifier / object / context
+ Text -- ^ Error description
+ | TemplateFileNotFoundError
+ Text -- ^ Template name
+ | TemplateParseError
+ Text -- ^ Template name
+ Text -- ^ Error message
+ | FatalError
+ Text
+ | PositionedError
+ !SourcePosition
+ !RuntimeError
+ deriving (Show, Eq)
+
+instance Exception RuntimeError where
+
+-- | Pretty-print a 'RuntimeError'. The output is meant to be useful as a
+-- user-facing error message.
+prettyRuntimeError :: RuntimeError -> String
+prettyRuntimeError (NotImplementedError what) =
+ printf "Not implemented: %s"
+ what
+prettyRuntimeError (ArgumentError callee argument expected actual) =
+ printf "Argument error in argument '%s' to %s: expected %s, but got %s."
+ argument callee expected actual
+prettyRuntimeError (TagError context expected actual) =
+ printf "Type error in %s: expected %s, but got %s."
+ context expected actual
+prettyRuntimeError (NonCallableObjectError obj) =
+ printf "Non-callable error: %s is not callable."
+ obj
+prettyRuntimeError (NotInScopeError thing) =
+ printf "Not in scope: %s"
+ thing
+prettyRuntimeError (NumericError context what) =
+ printf "Numeric error in %s: %s"
+ context what
+prettyRuntimeError (TemplateFileNotFoundError name) =
+ printf "Template file not found: %s"
+ name
+prettyRuntimeError (TemplateParseError name msg) =
+ printf "Template parser error in %s:\n%s"
+ name msg
+prettyRuntimeError (FatalError what) =
+ printf "FATAL ERROR: %s"
+ what
+prettyRuntimeError (PositionedError (SourcePosition file line column) err) =
+ printf "In %s:%i:%i:\n%s"
+ file line column (prettyRuntimeError err)
+
diff --git a/src/Language/Ginger/SourcePosition.hs b/src/Language/Ginger/SourcePosition.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/SourcePosition.hs
@@ -0,0 +1,17 @@
+module Language.Ginger.SourcePosition
+where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+data SourcePosition =
+ SourcePosition
+ { sourceFile :: !Text
+ , sourceLine :: !Int
+ , sourceColumn :: !Int
+ }
+ deriving (Show, Eq)
+
+prettySourcePosition :: SourcePosition -> String
+prettySourcePosition s =
+ Text.unpack (sourceFile s) ++ ":" ++ show (sourceLine s) ++ ":" ++ show (sourceColumn s)
diff --git a/src/Language/Ginger/Value.hs b/src/Language/Ginger/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Ginger/Value.hs
@@ -0,0 +1,1244 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Language.Ginger.Value
+where
+
+import Control.Monad.Except (runExceptT, throwError, MonadError)
+import Control.Monad.Reader (MonadReader (..))
+import Control.Monad.Trans (MonadTrans, lift)
+import Data.Aeson
+ ( FromJSON (..)
+ , FromJSONKey (..)
+ , ToJSON (..)
+ , FromJSONKeyFunction (..)
+ , ToJSONKey (..)
+ )
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Lazy as LBS
+import Data.Foldable (fold)
+import Data.Int
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Scientific (floatingOrInteger)
+import Data.String (IsString (..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Text.Encoding (decodeUtf8)
+import qualified Data.Text.Lazy as LText
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Word
+import GHC.Float (float2Double)
+import Test.Tasty.QuickCheck (Arbitrary (..))
+import qualified Test.Tasty.QuickCheck as QC
+
+import Language.Ginger.AST
+import Language.Ginger.RuntimeError
+
+data Env m =
+ Env
+ { envVars :: !(Map Identifier (Value m))
+ , envRootMay :: Maybe (Env m)
+ }
+ deriving (Eq)
+
+envRoot :: Env m -> Env m
+envRoot e =
+ fromMaybe e $ envRootMay e
+
+emptyEnv :: Env m
+emptyEnv = Env mempty Nothing
+
+instance Semigroup (Env m) where
+ a <> b = Env
+ { envVars = envVars a <> envVars b
+ , envRootMay = envRootMay a <> envRootMay b
+ }
+
+instance Monoid (Env m) where
+ mempty = emptyEnv
+
+type TemplateLoader m = Text -> m (Maybe Text)
+
+type Encoder m = Text -> m Encoded
+
+data Context m =
+ Context
+ { contextEncode :: Encoder m
+ , contextLoadTemplateFile :: TemplateLoader m
+ , contextVars :: !(Map Identifier (Value m))
+ , contextOutput :: !OutputPolicy
+ }
+
+data OutputPolicy
+ = Quiet
+ | Output
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+instance Semigroup OutputPolicy where
+ Quiet <> Quiet = Quiet
+ _ <> _ = Output
+
+instance Monoid OutputPolicy where
+ mappend = (<>)
+ mempty = Quiet
+
+emptyContext :: Applicative m => Context m
+emptyContext =
+ Context
+ { contextEncode = pure . Encoded
+ , contextLoadTemplateFile = const $ pure Nothing
+ , contextVars = mempty
+ , contextOutput = Output
+ }
+
+data Scalar
+ = NoneScalar
+ | BoolScalar !Bool
+ | StringScalar !Text
+ | EncodedScalar !Encoded
+ | BytesScalar !ByteString
+ | IntScalar !Integer
+ | FloatScalar !Double
+ deriving (Show, Eq, Ord)
+
+instance FromJSON Scalar where
+ parseJSON JSON.Null =
+ pure NoneScalar
+ parseJSON (JSON.Bool b) =
+ pure $ BoolScalar b
+ parseJSON (JSON.String s) =
+ pure $ StringScalar s
+ parseJSON (JSON.Number i) =
+ pure $ either FloatScalar IntScalar $ floatingOrInteger i
+ parseJSON x = JSON.unexpected x
+
+instance ToJSON Scalar where
+ toJSON NoneScalar = JSON.Null
+ toJSON (BoolScalar b) = JSON.Bool b
+ toJSON (StringScalar s) = toJSON s
+ toJSON (EncodedScalar (Encoded e)) = JSON.String e
+ toJSON (BytesScalar bs) =
+ JSON.object
+ [ ("@type", JSON.String "bytes")
+ , ("@data", toJSON (BS.unpack bs))
+ ]
+ toJSON (IntScalar i) = toJSON i
+ toJSON (FloatScalar f) = toJSON f
+
+instance FromJSONKey Scalar where
+ fromJSONKey = FromJSONKeyText StringScalar
+
+instance ToJSONKey Scalar where
+ toJSONKey = JSON.toJSONKeyText scalarToText
+
+scalarToText :: Scalar -> Text
+scalarToText NoneScalar = ""
+scalarToText (BoolScalar True) = "true"
+scalarToText (BoolScalar False) = "false"
+scalarToText (StringScalar str) = str
+scalarToText (BytesScalar b) = decodeUtf8 . Base64.encode $ b
+scalarToText (EncodedScalar (Encoded e)) = e
+scalarToText (IntScalar i) = Text.show i
+scalarToText (FloatScalar f) = Text.show f
+
+newtype RefID = RefID { unRefID :: Int }
+ deriving (Show, Ord, Eq, Bounded, Enum)
+
+-- | A value, as using by the interpreter.
+data Value m
+ = ScalarV !Scalar
+ | ListV !(Vector (Value m))
+ | DictV !(Map Scalar (Value m))
+ | NativeV !(NativeObject m)
+ | ProcedureV !(Procedure m)
+ | TestV !(Test m)
+ | FilterV !(Filter m)
+ | MutableRefV !RefID
+
+instance FromJSON (Value m) where
+ parseJSON v@JSON.Object {} = DictV <$> parseJSON v
+ parseJSON v@JSON.Array {} = ListV <$> parseJSON v
+ parseJSON v = ScalarV <$> parseJSON v
+
+instance ToJSON (Value m) where
+ toJSON (ScalarV s) = toJSON s
+ toJSON (ListV xs) = toJSON xs
+ toJSON (DictV d) = toJSON d
+ toJSON x = toJSON (show x)
+
+traverseValue :: Monoid a => (Value m -> a) -> Value m -> a
+traverseValue p v@(ListV xs) =
+ p v <> fold (fmap (traverseValue p) xs)
+traverseValue p v@(DictV m) =
+ p v <> mconcat (map (traverseValue p . snd) $ Map.toList m)
+traverseValue p v = p v
+
+instance Show (Value m) where
+ show (ScalarV s) = show s
+ show (ListV xs) = "ListV " ++ show xs
+ show (DictV m) = "DictV " ++ show (Map.toAscList m)
+ show (NativeV {}) = "<>"
+ show (ProcedureV {}) = "<>"
+ show (TestV {}) = "<>"
+ show (FilterV {}) = "<>"
+ show (MutableRefV i) = show i
+
+instance Eq (Value m) where
+ ScalarV a == ScalarV b = a == b
+ ListV a == ListV b = a == b
+ DictV a == DictV b = a == b
+ _ == _ = False
+
+tagNameOf :: Value m -> Text
+tagNameOf ScalarV {} = "scalar"
+tagNameOf ListV {} = "list"
+tagNameOf DictV {} = "dict"
+tagNameOf NativeV {} = "native"
+tagNameOf ProcedureV {} = "procedure"
+tagNameOf TestV {} = "test"
+tagNameOf FilterV {} = "filter"
+tagNameOf MutableRefV {} = "mutref"
+
+pattern NoneV :: Value m
+pattern NoneV = ScalarV NoneScalar
+
+pattern BoolV :: Bool -> Value m
+pattern BoolV b = ScalarV (BoolScalar b)
+
+pattern TrueV :: Value m
+pattern TrueV = BoolV True
+
+pattern FalseV :: Value m
+pattern FalseV = BoolV False
+
+pattern StringV :: Text -> Value m
+pattern StringV v = ScalarV (StringScalar v)
+
+pattern EncodedV :: Encoded -> Value m
+pattern EncodedV v = ScalarV (EncodedScalar v)
+
+pattern BytesV :: ByteString -> Value m
+pattern BytesV v = ScalarV (BytesScalar v)
+
+pattern IntV :: Integer -> Value m
+pattern IntV v = ScalarV (IntScalar v)
+
+pattern FloatV :: Double -> Value m
+pattern FloatV v = ScalarV (FloatScalar v)
+
+newtype ObjectID = ObjectID { unObjectID :: Text }
+ deriving (Eq)
+
+instance IsString ObjectID where
+ fromString = ObjectID . Text.pack
+
+data TypeDoc
+ = TypeDocNone
+ | TypeDocAny
+ | TypeDocSingle !Text
+ | TypeDocAlternatives !(Vector Text)
+ deriving (Show)
+
+instance ToValue TypeDoc m where
+ toValue TypeDocNone = StringV "none"
+ toValue TypeDocAny = StringV "any"
+ toValue (TypeDocSingle t) = StringV t
+ toValue (TypeDocAlternatives xs) =
+ dictV ["oneof" .= xs]
+
+data ArgumentDoc =
+ ArgumentDoc
+ { argumentDocName :: !Text
+ , argumentDocType :: !(Maybe TypeDoc)
+ , argumentDocDefault :: !(Maybe Text)
+ , argumentDocDescription :: !Text
+ }
+ deriving (Show)
+
+instance ToValue ArgumentDoc m where
+ toValue a =
+ dictV
+ [ "name" .= argumentDocName a
+ , "type" .= argumentDocType a
+ , "default" .= argumentDocDefault a
+ , "description" .= argumentDocDescription a
+ ]
+
+data ProcedureDoc =
+ ProcedureDoc
+ { procedureDocName :: !Text
+ , procedureDocArgs :: !(Vector ArgumentDoc)
+ , procedureDocReturnType :: !(Maybe TypeDoc)
+ , procedureDocDescription :: !Text
+ }
+ deriving (Show)
+
+instance ToValue ProcedureDoc m where
+ toValue d =
+ dictV
+ [ "name" .= procedureDocName d
+ , "args" .= procedureDocArgs d
+ , "returnType" .= procedureDocReturnType d
+ , "description" .= procedureDocDescription d
+ ]
+
+data Procedure m
+ = NativeProcedure
+ !ObjectID
+ !(Maybe ProcedureDoc)
+ !( [(Maybe Identifier, Value m)]
+ -> Context m
+ -> m (Either RuntimeError (Value m))
+ )
+ | GingerProcedure !(Env m) ![(Identifier, Maybe (Value m))] !Expr
+ | NamespaceProcedure
+
+instance Eq (Procedure m) where
+ NativeProcedure a _ _ == NativeProcedure b _ _ =
+ a == b
+ GingerProcedure env1 argspec1 body1 == GingerProcedure env2 argspec2 body2 =
+ (env1, argspec1, body1) == (env2, argspec2, body2)
+ NamespaceProcedure == NamespaceProcedure = True
+ _ == _ = False
+
+pureNativeProcedure :: Applicative m
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> ([(Maybe Identifier, Value m)] -> Either RuntimeError (Value m))
+ -> Procedure m
+pureNativeProcedure oid doc f =
+ NativeProcedure oid doc $ \args _ -> pure (f args)
+
+nativeFunc :: (Monad m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> m (Either RuntimeError (Value m)))
+ -> Procedure m
+nativeFunc oid doc f =
+ NativeProcedure oid doc $ \args _ -> case args of
+ [] ->
+ pure . Left $
+ ArgumentError
+ ""
+ ""
+ "value"
+ "end of arguments"
+ [(_, x)] ->
+ f x
+ (_:(name, x):_) ->
+ pure . Left $
+ ArgumentError
+ ""
+ (maybe "" identifierName $ name)
+ "end of arguments"
+ (tagNameOf $ x)
+
+pureNativeFunc :: (Applicative m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> Either RuntimeError (Value m))
+ -> Procedure m
+pureNativeFunc oid doc f =
+ NativeProcedure oid doc $ \args _ -> case args of
+ [] ->
+ pure . Left $
+ ArgumentError
+ ""
+ ""
+ "value"
+ "end of arguments"
+ [(_, x)] ->
+ pure $ f x
+ (_:(name, x):_) ->
+ pure . Left $
+ ArgumentError
+ ""
+ (maybe "" identifierName $ name)
+ "end of arguments"
+ (tagNameOf $ x)
+
+pureNativeFunc2 :: (Applicative m)
+ => ObjectID
+ -> Maybe ProcedureDoc
+ -> (Value m -> Value m -> Either RuntimeError (Value m))
+ -> Procedure m
+pureNativeFunc2 oid doc f =
+ NativeProcedure oid doc $ \args _ -> case args of
+ [] ->
+ pure . Left $
+ ArgumentError
+ ""
+ ""
+ "value"
+ "end of arguments"
+ [_] ->
+ pure . Left $
+ ArgumentError
+ ""
+ ""
+ "value"
+ "end of arguments"
+ [(_, x), (_, y)] ->
+ pure $ f x y
+ (_:_:(name, x):_) ->
+ pure . Left $
+ ArgumentError
+ ""
+ (maybe "" identifierName $ name)
+ "end of arguments"
+ (tagNameOf $ x)
+
+type MetaFunc m a =
+ Expr
+ -> [(Maybe Identifier, Value m)]
+ -> Context m
+ -> Env m
+ -> m (Either RuntimeError a)
+
+type TestFunc m = MetaFunc m Bool
+
+type FilterFunc m = MetaFunc m (Value m)
+
+data Test m =
+ NativeTest
+ { testDoc :: !(Maybe ProcedureDoc)
+ , runTest :: !(TestFunc m)
+ }
+
+data Filter m =
+ NativeFilter
+ { filterDoc :: !(Maybe ProcedureDoc)
+ , runFilter :: !(FilterFunc m)
+ }
+
+data NativeObject m =
+ NativeObject
+ { nativeObjectGetFieldNames :: m [Scalar]
+ , nativeObjectGetField :: Scalar -> m (Maybe (Value m))
+ , nativeObjectGetAttribute :: Identifier -> m (Maybe (Value m))
+ , nativeObjectStringified :: m Text
+ , nativeObjectEncoded :: Context m -> m Encoded
+ , nativeObjectAsList :: m (Maybe (Vector (Value m)))
+ , nativeObjectCall :: Maybe
+ (NativeObject m
+ -> [(Maybe Identifier, Value m)]
+ -> m (Either RuntimeError (Value m))
+ )
+ , nativeObjectEq :: NativeObject m
+ -> NativeObject m
+ -> m (Either RuntimeError Bool)
+ }
+
+nativeObjectAsDict :: Monad m
+ => NativeObject m
+ -> m (Maybe (Map Scalar (Value m)))
+nativeObjectAsDict o = do
+ fieldNames <- nativeObjectGetFieldNames o
+ case fieldNames of
+ [] -> pure Nothing
+ keys -> do
+ pairs <- mapM makePair keys
+ pure . Just $ Map.fromList pairs
+ where
+ makePair k = (k,) . fromMaybe NoneV <$> nativeObjectGetField o k
+
+(-->) :: obj -> (obj -> obj -> a) -> a
+obj --> field = field obj obj
+
+defNativeObject :: Monad m => NativeObject m
+defNativeObject =
+ NativeObject
+ { nativeObjectGetFieldNames = pure []
+ , nativeObjectGetField = \_ -> pure Nothing
+ , nativeObjectGetAttribute = \_ -> pure Nothing
+ , nativeObjectStringified = pure ""
+ , nativeObjectEncoded = const $ pure (Encoded "[[native object]]")
+ , nativeObjectAsList = pure Nothing
+ , nativeObjectCall = Nothing
+ , nativeObjectEq = \_self _other -> pure . Right $ False
+ }
+
+instance IsString Scalar where
+ fromString = StringScalar . Text.pack
+
+instance IsString (Value m) where
+ fromString = ScalarV . fromString
+
+class ToScalar a where
+ toScalar :: a -> Scalar
+
+instance ToScalar Scalar where
+ toScalar = id
+
+instance ToScalar () where
+ toScalar () = NoneScalar
+
+instance ToScalar Bool where
+ toScalar = BoolScalar
+
+instance ToScalar Integer where
+ toScalar = IntScalar
+
+toIntScalar :: Integral a => a -> Scalar
+toIntScalar = IntScalar . fromIntegral
+
+instance ToScalar Int where
+ toScalar = toIntScalar
+
+instance ToScalar Word where
+ toScalar = toIntScalar
+
+instance ToScalar Int8 where
+ toScalar = toIntScalar
+
+instance ToScalar Int16 where
+ toScalar = toIntScalar
+
+instance ToScalar Int32 where
+ toScalar = toIntScalar
+
+instance ToScalar Int64 where
+ toScalar = toIntScalar
+
+instance ToScalar Word8 where
+ toScalar = toIntScalar
+
+instance ToScalar Word16 where
+ toScalar = toIntScalar
+
+instance ToScalar Word32 where
+ toScalar = toIntScalar
+
+instance ToScalar Word64 where
+ toScalar = toIntScalar
+
+instance ToScalar Double where
+ toScalar = FloatScalar
+
+instance ToScalar Float where
+ toScalar = FloatScalar . float2Double
+
+
+instance ToScalar Text where
+ toScalar = StringScalar
+
+instance ToScalar LText.Text where
+ toScalar = StringScalar . LText.toStrict
+
+instance ToScalar ByteString where
+ toScalar = BytesScalar
+
+instance ToScalar LBS.ByteString where
+ toScalar = BytesScalar . LBS.toStrict
+
+instance ToScalar a => ToScalar (Maybe a) where
+ toScalar Nothing = NoneScalar
+ toScalar (Just x) = toScalar x
+
+instance (ToScalar a, ToScalar b) => ToScalar (Either a b) where
+ toScalar (Left x) = toScalar x
+ toScalar (Right x) = toScalar x
+
+instance ToScalar Identifier where
+ toScalar = toScalar . identifierName
+
+class FnArgValue a where
+ fromArgValue :: Value m -> Either RuntimeError a
+
+--------------------------------------------------------------------------------
+-- FromValue
+--------------------------------------------------------------------------------
+
+class FromValue a m where
+ fromValue :: Value m -> m (Either RuntimeError a)
+
+--------------------------------------------------------------------------------
+-- FromValue instances
+--------------------------------------------------------------------------------
+
+instance Applicative m => FromValue (Value m) m where
+ fromValue = pure . Right
+
+instance Applicative m => FromValue Scalar m where
+ fromValue = pure . asScalarVal
+
+instance Applicative m => FromValue Text m where
+ fromValue = pure . asTextVal
+
+instance Applicative m => FromValue Integer m where
+ fromValue = pure . asIntVal
+
+instance Applicative m => FromValue Int m where
+ fromValue = fmap (fmap fromInteger) . pure . asIntVal
+
+instance Applicative m => FromValue Double m where
+ fromValue = pure . asFloatVal
+
+instance Applicative m => FromValue Bool m where
+ fromValue = pure . asBoolVal
+
+instance Applicative m => FromValue () m where
+ fromValue NoneV = pure $ Right ()
+ fromValue x = pure . Left $ TagError "" "fromValue" (tagNameOf x)
+
+instance (Applicative m, FromValue a m) => FromValue (Maybe a) m where
+ fromValue NoneV = pure $ Right Nothing
+ fromValue x = fmap (fmap Just) $ fromValue x
+
+instance (Monad m, FromValue l m, FromValue r m) => FromValue (Either l r) m where
+ fromValue v = do
+ fromValue v >>= \case
+ Right r -> pure . Right $ Right r
+ _ -> do
+ fromValue v >>= \case
+ Left e -> pure $ Left e
+ Right l -> pure . Right $ Left l
+
+instance (Monad m, FromValue a m) => FromValue [a] m where
+ fromValue x = runExceptT $ do
+ items :: [Value m] <- eitherExceptM (asListVal x)
+ mapM (eitherExceptM . fromValue) items
+
+instance (Monad m, FromValue a m) => FromValue (Vector a) m where
+ fromValue x = runExceptT $ do
+ items :: Vector (Value m) <- eitherExceptM (asVectorVal x)
+ V.mapM (eitherExceptM . fromValue) items
+
+instance (Monad m, FromValue a m) => FromValue (Map Scalar a) m where
+ fromValue x = runExceptT $ do
+ items :: Map Scalar (Value m) <- eitherExceptM (asDictVal x)
+ Map.fromList <$> mapM (\(k, v) -> (k,) <$> eitherExceptM (fromValue v)) (Map.toList items)
+
+--------------------------------------------------------------------------------
+-- ToValue
+--------------------------------------------------------------------------------
+
+class ToValue a m where
+ toValue :: a -> Value m
+
+instance ToValue (Value m) m where
+ toValue = id
+
+class FnToValue a m where
+ fnToValue :: ObjectID -> Maybe ProcedureDoc -> a -> Value m
+
+--------------------------------------------------------------------------------
+-- ToValue Scalar instances
+--------------------------------------------------------------------------------
+
+instance ToValue Scalar a where
+ toValue = ScalarV
+
+instance ToValue () a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Bool a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Integer a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Int a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Int8 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Int16 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Int32 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Int64 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Word a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Word8 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Word16 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Word32 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Word64 a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Double a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Float a where
+ toValue = ScalarV . toScalar
+
+instance ToValue Text a where
+ toValue = ScalarV . toScalar
+
+instance ToValue LText.Text a where
+ toValue = ScalarV . toScalar
+
+instance ToValue ByteString a where
+ toValue = ScalarV . toScalar
+
+instance ToValue LBS.ByteString a where
+ toValue = ScalarV . toScalar
+
+--------------------------------------------------------------------------------
+-- Compound / derived instances
+--------------------------------------------------------------------------------
+
+instance ToValue a m => ToValue (Maybe a) m where
+ toValue Nothing = ScalarV NoneScalar
+ toValue (Just x) = toValue x
+
+instance (ToValue a m, ToValue b m) => ToValue (Either a b) m where
+ toValue (Left x) = toValue x
+ toValue (Right x) = toValue x
+
+instance ToValue a m => ToValue (Vector a) m where
+ toValue = ListV . fmap toValue
+
+instance ToValue a m => ToValue [a] m where
+ toValue = ListV . V.fromList . map toValue
+
+instance (ToValue a1 m, ToValue a2 m)
+ => ToValue (a1, a2) m where
+ toValue (x1, x2) =
+ ListV $ V.fromList [toValue x1, toValue x2]
+
+instance (ToValue a1 m, ToValue a2 m, ToValue a3 m)
+ => ToValue (a1, a2, a3) m where
+ toValue (x1, x2, x3) =
+ ListV $ V.fromList [toValue x1, toValue x2, toValue x3]
+
+instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m)
+ => ToValue (a1, a2, a3, a4) m where
+ toValue (x1, x2, x3, x4) =
+ ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4]
+
+instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m)
+ => ToValue (a1, a2, a3, a4, a5) m where
+ toValue (x1, x2, x3, x4, x5) =
+ ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5]
+
+instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m, ToValue a6 m)
+ => ToValue (a1, a2, a3, a4, a5, a6) m where
+ toValue (x1, x2, x3, x4, x5, x6) =
+ ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5, toValue x6]
+
+instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m, ToValue a6 m, ToValue a7 m)
+ => ToValue (a1, a2, a3, a4, a5, a6, a7) m where
+ toValue (x1, x2, x3, x4, x5, x6, x7) =
+ ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5, toValue x6, toValue x7]
+
+instance (ToScalar k, ToValue v m) => ToValue (Map k v) m where
+ toValue = DictV . Map.mapKeys toScalar . Map.map toValue
+
+instance ToValue v m => ToValue (Map LText.Text v) m where
+ toValue = toValue . Map.mapKeys LText.toStrict
+
+instance ToValue v m => ToValue (Map String v) m where
+ toValue = toValue . Map.mapKeys Text.pack
+
+--------------------------------------------------------------------------------
+-- Function instances
+--------------------------------------------------------------------------------
+
+class ToNativeProcedure m a where
+ toNativeProcedure :: a -> [(Maybe Identifier, Value m)] -> Context m -> m (Either RuntimeError (Value m))
+
+instance Applicative m => ToNativeProcedure m (Value m) where
+ toNativeProcedure val [] _ =
+ pure (Right val)
+ toNativeProcedure _ _ _ =
+ pure . Left $
+ ArgumentError "" "" "end of arguments" "value"
+
+instance Applicative m => ToNativeProcedure m (m (Value m)) where
+ toNativeProcedure action [] _ =
+ Right <$> action
+ toNativeProcedure _ _ _ =
+ pure . Left $
+ ArgumentError "" "" "end of arguments" "value"
+
+instance Applicative m => ToNativeProcedure m (m (Either RuntimeError (Value m))) where
+ toNativeProcedure action [] _ =
+ action
+ toNativeProcedure _ _ _ =
+ pure . Left $
+ ArgumentError "" "" "end of arguments" "value"
+
+instance (Applicative m, ToNativeProcedure m a) => ToNativeProcedure m (Value m -> a) where
+ toNativeProcedure _ [] _ =
+ pure . Left $
+ ArgumentError "" "" "value" "end of arguments"
+ toNativeProcedure _ ((Just _, _):_) _ =
+ pure . Left $
+ ArgumentError "" "" "positional argument" "named argument"
+ toNativeProcedure f ((Nothing, v):xs) ctx =
+ toNativeProcedure (f v) xs ctx
+
+
+instance Applicative m => FnToValue (Value m -> Value m) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> Value m) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+
+instance Applicative m => FnToValue (Value m -> m (Value m)) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> m (Value m)) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> m (Value m)) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> m (Value m)) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> m (Value m)) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+
+instance Applicative m => FnToValue (Value m -> m (Either RuntimeError (Value m))) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> m (Either RuntimeError (Value m))) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
+ fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f
+
+--------------------------------------------------------------------------------
+-- Procedure helpers
+--------------------------------------------------------------------------------
+
+eitherExcept :: (Monad m, MonadError e (t m))
+ => Either e a -> t m a
+eitherExcept = either throwError pure
+
+eitherExceptM :: (Monad m, MonadError e (t m), MonadTrans t)
+ => m (Either e a) -> t m a
+eitherExceptM = (>>= eitherExcept) . lift
+
+resolveArgs :: Text
+ -> [(Identifier, Maybe (Value m))]
+ -> [(Maybe Identifier, Value m)]
+ -> Either RuntimeError (Map Identifier (Value m))
+resolveArgs context specs args =
+ let kwargs0 = Map.fromList [(k, v) | (Just k, v) <- args]
+ varargs0 = [v | (Nothing, v) <- args]
+ in go specs kwargs0 varargs0
+ where
+ go ((argName, defVal):xs) kwargs varargs =
+ case Map.lookup argName kwargs of
+ Nothing ->
+ -- positional argument
+ case varargs of
+ [] ->
+ -- No more arguments passed, look for default value
+ maybe
+ -- No default, argument required
+ (Left $
+ ArgumentError
+ context
+ (identifierName argName)
+ "argument"
+ "end of arguments"
+ )
+ -- Default exists, use it.
+ (\val ->
+ Map.insert argName val <$> go xs kwargs varargs
+ )
+ defVal
+ (v:varargs') ->
+ -- Argument passed, use it.
+ Map.insert argName v <$> go xs kwargs varargs'
+ Just v ->
+ -- Keyword argument found.
+ Map.insert argName v <$> go xs (Map.delete argName kwargs) varargs
+
+ go [] kwargs varargs =
+ -- Map remaining arguments to @varargs@ and @kwargs@.
+ Right $ Map.fromList
+ [ ("varargs", ListV $ V.fromList varargs)
+ , ("kwargs", DictV (Map.mapKeys (toScalar . identifierName) kwargs))
+ ]
+
+leftNaN :: Double -> Either RuntimeError Double
+leftNaN c | isNaN c = Left $ NumericError "" "not a number"
+leftNaN c | isInfinite c = Left $ NumericError "" "infinity"
+leftNaN c = Right c
+
+numericFunc :: Monad m
+ => (Integer -> Integer)
+ -> (Double -> Double)
+ -> Value m
+ -> Either RuntimeError (Value m)
+numericFunc f g =
+ numericFuncCatch f' g'
+ where
+ f' x = Right (f x)
+ g' x = Right (g x)
+
+numericFuncCatch :: Monad m
+ => (Integer -> Either RuntimeError Integer)
+ -> (Double -> Either RuntimeError Double)
+ -> Value m
+ -> Either RuntimeError (Value m)
+numericFuncCatch f _ (IntV a) = IntV <$> f a
+numericFuncCatch _ f (FloatV a) = FloatV <$> (leftNaN =<< f a)
+numericFuncCatch _ _ a = Left (TagError "" "number" (tagNameOf a))
+
+asOptionalVal :: (Value m -> Either RuntimeError a) -> Value m -> Either RuntimeError (Maybe a)
+asOptionalVal _ NoneV = Right Nothing
+asOptionalVal asVal x = Just <$> asVal x
+
+asIntVal :: Value m -> Either RuntimeError Integer
+asIntVal (IntV a) = Right a
+asIntVal x = Left $ TagError "conversion to int" "int" (tagNameOf x)
+
+asFloatVal :: Value m -> Either RuntimeError Double
+asFloatVal (FloatV a) = Right a
+asFloatVal (IntV a) = Right (fromInteger a)
+asFloatVal x = Left $ TagError "conversion to float" "float" (tagNameOf x)
+
+asBoolVal :: Value m -> Either RuntimeError Bool
+asBoolVal (BoolV a) = Right a
+asBoolVal NoneV = Right False
+asBoolVal x = Left $ TagError "conversion to bool" "bool" (tagNameOf x)
+
+asVectorVal :: Monad m => Value m -> m (Either RuntimeError (Vector (Value m)))
+asVectorVal (ListV a) = pure . Right $ a
+asVectorVal (NativeV n) =
+ maybe
+ (Left $ TagError "conversion to list" "list" "non-list native object")
+ Right <$>
+ nativeObjectAsList n
+asVectorVal x = pure . Left $ TagError "conversion to list" "list" (tagNameOf x)
+
+asListVal :: Monad m => Value m -> m (Either RuntimeError [Value m])
+asListVal (ListV a) = pure . Right $ V.toList a
+asListVal (NativeV n) =
+ maybe
+ (Left $ TagError "conversion to list" "list" "non-list native object")
+ (Right . V.toList) <$>
+ nativeObjectAsList n
+asListVal x = pure . Left $ TagError "conversion to list" "list" (tagNameOf x)
+
+asDictVal :: Monad m => Value m -> m (Either RuntimeError (Map Scalar (Value m)))
+asDictVal (DictV a) = pure $ Right a
+asDictVal (NativeV n) =
+ maybe
+ (Left $ TagError "conversion to dict" "dict" "non-dict native object")
+ Right <$>
+ nativeObjectAsDict n
+asDictVal x = pure . Left $ TagError "conversion to dict" "dict" (tagNameOf x)
+
+asTextVal :: Value m -> Either RuntimeError Text
+asTextVal (StringV a) = Right a
+asTextVal (EncodedV (Encoded a)) = Right a
+asTextVal (IntV a) = Right (Text.show a)
+asTextVal (FloatV a) = Right (Text.show a)
+asTextVal NoneV = Right ""
+asTextVal x = Left $ TagError "conversion to string" "string" (tagNameOf x)
+
+asScalarVal :: Value m -> Either RuntimeError Scalar
+asScalarVal (ScalarV a) = Right a
+asScalarVal x = Left $ TagError "conversion to scalar" "scalar" (tagNameOf x)
+
+intFunc :: (Monad m, ToValue a m)
+ => (Integer -> Either RuntimeError a)
+ -> Value m
+ -> Either RuntimeError (Value m)
+intFunc f a = toValue <$> (asIntVal a >>= f)
+
+floatFunc :: (Monad m, ToValue a m)
+ => (Double -> Either RuntimeError a)
+ -> Value m
+ -> Either RuntimeError (Value m)
+floatFunc f a = toValue <$> (asFloatVal a >>= f)
+
+boolFunc :: (Monad m, ToValue a m)
+ => (Bool -> a)
+ -> Value m
+ -> Either RuntimeError (Value m)
+boolFunc f (BoolV a) = pure . toValue $ f a
+boolFunc _ a = Left (TagError "bool function" "bool" (tagNameOf a))
+
+textFunc :: (Monad m, ToValue a m)
+ => (Text -> Either RuntimeError a)
+ -> Value m
+ -> Either RuntimeError (Value m)
+textFunc f (StringV a) = toValue <$> f a
+textFunc f (EncodedV (Encoded a)) = toValue <$> f a
+textFunc f (IntV a) = toValue <$> f (Text.show a)
+textFunc f (FloatV a) = toValue <$> f (Text.show a)
+textFunc f NoneV = toValue <$> f ""
+textFunc _ a = Left (TagError "text function" "int" (tagNameOf a))
+
+numericFunc2 :: Monad m
+ => (Integer -> Integer -> Integer)
+ -> (Double -> Double -> Double)
+ -> Value m
+ -> Value m
+ -> Either RuntimeError (Value m)
+numericFunc2 f g =
+ numericFunc2Catch f' g'
+ where
+ f' x y = Right (f x y)
+ g' x y = Right (g x y)
+
+numericFunc2Catch :: Monad m
+ => (Integer -> Integer -> Either RuntimeError Integer)
+ -> (Double -> Double -> Either RuntimeError Double)
+ -> Value m
+ -> Value m
+ -> Either RuntimeError (Value m)
+numericFunc2Catch f _ (IntV a) (IntV b) = IntV <$> (a `f` b)
+numericFunc2Catch _ f (FloatV a) (FloatV b) = FloatV <$> (leftNaN =<< a `f` b)
+numericFunc2Catch _ f (IntV a) (FloatV b) = FloatV <$> (leftNaN =<< fromInteger a `f` b)
+numericFunc2Catch _ f (FloatV a) (IntV b) = FloatV <$> (leftNaN =<< a `f` fromInteger b)
+numericFunc2Catch _ _ (FloatV _) b = Left (TagError "numeric function" "number" (tagNameOf b))
+numericFunc2Catch _ _ (IntV _) b = Left (TagError "numeric function" "number" (tagNameOf b))
+numericFunc2Catch _ _ b _ = Left (TagError "numeric function" "number" (tagNameOf b))
+
+intFunc2 :: Monad m
+ => (Integer -> Integer -> Either RuntimeError Integer)
+ -> Value m
+ -> Value m
+ -> Either RuntimeError (Value m)
+intFunc2 f a b = do
+ x <- asIntVal a
+ y <- asIntVal b
+ IntV <$> f x y
+
+floatFunc2 :: Monad m
+ => (Double -> Double -> Either RuntimeError Double)
+ -> Value m
+ -> Value m
+ -> Either RuntimeError (Value m)
+floatFunc2 f (IntV a) b = floatFunc2 f (FloatV $ fromIntegral a) b
+floatFunc2 f (FloatV a) (IntV b) = floatFunc2 f (FloatV a) (FloatV $ fromIntegral b)
+floatFunc2 f (FloatV a) (FloatV b) = FloatV <$> (a `f` b)
+floatFunc2 _ (FloatV _) b = Left (TagError "floating-point function" "float" (tagNameOf b))
+floatFunc2 _ b _ = Left (TagError "floating-point function" "float" (tagNameOf b))
+
+boolFunc2 :: Monad m
+ => (Bool -> Bool -> Bool)
+ -> Value m
+ -> Value m
+ -> Either RuntimeError (Value m)
+boolFunc2 f a b = BoolV <$> (f <$> asBoolVal a <*> asBoolVal b)
+
+native :: (Monad m, MonadTrans t, MonadError RuntimeError (t m))
+ => m (Either RuntimeError a)
+ -> t m a
+native action =
+ lift action >>= either throwError pure
+
+encodeText :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ , MonadReader (Context m) (t m)
+ )
+ => Text
+ -> t m Encoded
+encodeText str = do
+ ctx <- ask
+ encodeTextWith ctx str
+
+encodeTextWith :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ )
+ => Context m
+ -> Text
+ -> t m Encoded
+encodeTextWith ctx str = do
+ let encoder = contextEncode ctx
+ native (Right <$> encoder str)
+
+encode :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ , MonadReader (Context m) (t m)
+ )
+ => Value m
+ -> t m Encoded
+encode v = do
+ ctx <- ask
+ encodeWith ctx v
+
+encodeWith :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ )
+ => Context m
+ -> Value m
+ -> t m Encoded
+encodeWith _ (EncodedV e) = pure e
+encodeWith ctx (NativeV n) = native (Right <$> nativeObjectEncoded n ctx)
+encodeWith _ (ProcedureV _) = pure $ Encoded "[[procedure]]"
+encodeWith ctx v = encodeTextWith ctx =<< stringify v
+
+--------------------------------------------------------------------------------
+-- String / Encoding helpers
+--------------------------------------------------------------------------------
+
+stringify :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ )
+ => Value m
+ -> t m Text
+stringify NoneV = pure ""
+stringify TrueV = pure "true"
+stringify FalseV = pure ""
+stringify (StringV str) = pure str
+stringify (BytesV b) =
+ pure . decodeUtf8 . Base64.encode $ b
+stringify (EncodedV (Encoded e)) =
+ pure e
+stringify (IntV i) = pure $ Text.show i
+stringify (FloatV f) = pure $ Text.show f
+stringify (ScalarV s) = pure . Text.show $ s
+stringify (ListV xs) = do
+ elems <- V.mapM stringify xs
+ pure $ Text.intercalate ", " $ V.toList elems
+stringify (DictV m) = do
+ elems <- mapM stringifyKV $ Map.toAscList m
+ pure $ Text.intercalate ", " elems
+stringify (NativeV n) =
+ native (Right <$> nativeObjectStringified n)
+stringify (ProcedureV (NativeProcedure oid _ _)) =
+ pure $ "[[procedure " <> unObjectID oid <> "]]"
+stringify (ProcedureV (GingerProcedure {})) =
+ pure $ "[[procedure]]"
+stringify (ProcedureV NamespaceProcedure) =
+ pure $ "[[procedure namespace]]"
+stringify (TestV _) =
+ pure "[[test]]"
+stringify (FilterV _) =
+ pure "[[filter]]"
+stringify (MutableRefV ref) =
+ pure $ "[[ref#]]" <> Text.show (unRefID ref)
+
+stringifyKV :: ( Monad m
+ , MonadError RuntimeError (t m)
+ , MonadTrans t
+ )
+ => (Scalar, Value m)
+ -> t m Text
+stringifyKV (k, v) = do
+ kStr <- stringify (ScalarV k)
+ vStr <- stringify v
+ pure $ kStr <> ": " <> vStr
+
+
+--------------------------------------------------------------------------------
+-- Dictionary helpers
+--------------------------------------------------------------------------------
+
+dictV :: [(Scalar, Value m)] -> Value m
+dictV items = DictV $ Map.fromList items
+
+infixr 8 .=
+
+(.=) :: (ToValue v m) => Scalar -> v -> (Scalar, Value m)
+k .= v = (k, toValue v)
+
+--------------------------------------------------------------------------------
+-- Arbitrary instances
+--------------------------------------------------------------------------------
+
+instance Arbitrary Scalar where
+ arbitrary =
+ QC.oneof
+ [ pure NoneScalar
+ , BoolScalar <$> arbitrary
+ , StringScalar . Text.pack <$> QC.listOf arbitrary
+ , EncodedScalar . Encoded . Text.pack <$> QC.listOf arbitrary
+ , BytesScalar . BS.pack <$> QC.listOf arbitrary
+ , IntScalar <$> arbitrary
+ , FloatScalar <$> arbitrary
+ ]
+
+ shrink = \case
+ BoolScalar True -> [BoolScalar False]
+ StringScalar str | Text.null str -> []
+ StringScalar str -> [StringScalar $ Text.init str]
+ EncodedScalar (Encoded str) | Text.null str -> []
+ EncodedScalar (Encoded str) -> [EncodedScalar . Encoded $ Text.init str]
+ BytesScalar str | BS.null str -> []
+ BytesScalar str -> [BytesScalar $ BS.init str]
+ IntScalar i -> NoneScalar : (IntScalar <$> shrink i)
+ FloatScalar f -> NoneScalar : (FloatScalar <$> shrink f)
+ NoneScalar -> []
+ _ -> [NoneScalar]
+
+instance Monad m => Arbitrary (Value m) where
+ arbitrary =
+ QC.oneof
+ [ pure NoneV
+ , ScalarV <$> arbitrary
+ , ListV . V.fromList <$> fuelledList arbitrary
+ , DictV . Map.fromList <$> fuelledList arbitrary
+ , NativeV <$> arbitraryNative
+ , ProcedureV <$> arbitraryNativeProcedure
+ ]
+
+arbitraryNativeProcedure :: Monad m => QC.Gen (Procedure m)
+arbitraryNativeProcedure = do
+ retval <- QC.scale (`div` 2) arbitrary
+ oid <- ObjectID . ("arbitrary:" <>) . identifierName <$> arbitrary
+ pure $ NativeProcedure oid Nothing (\_ _ -> pure (Right retval))
+
+arbitraryNative :: Monad m => QC.Gen (NativeObject m)
+arbitraryNative = do
+ objectID <- arbitrary
+ pure defNativeObject
+ { nativeObjectGetFieldNames = pure ["id"]
+ , nativeObjectGetField = \case
+ "id" -> pure . Just . toValue . identifierName $ objectID
+ _ -> pure Nothing
+ , nativeObjectStringified = pure $ identifierName objectID
+ , nativeObjectEq = \self other -> do
+ otherID <- nativeObjectGetField other "id"
+ selfID <- nativeObjectGetField self "id"
+ pure . Right $ otherID == selfID
+ }
diff --git a/test/Language/Ginger/AST/Tests.hs b/test/Language/Ginger/AST/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Ginger/AST/Tests.hs
@@ -0,0 +1,14 @@
+module Language.Ginger.AST.Tests
+where
+
+-- import Language.Ginger.AST
+import Test.Tasty
+-- import Test.Tasty.QuickCheck
+-- import qualified Data.Text as Text
+-- import Data.String (IsString (..))
+
+tests :: TestTree
+tests = testGroup "Language.Ginger.AST"
+ [
+ ]
+
diff --git a/test/Language/Ginger/Interpret/Tests.hs b/test/Language/Ginger/Interpret/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Ginger/Interpret/Tests.hs
@@ -0,0 +1,2191 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Language.Ginger.Interpret.Tests
+where
+
+import Control.Monad (void)
+import Control.Monad.Except (throwError)
+import Control.Monad.Identity
+import Control.Monad.State (gets)
+import Data.Bits ((.&.))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Char (isControl, isSpace, isAlpha, isAlphaNum, chr)
+import Data.Either (isRight)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.List (sort, sortOn, intersperse)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (isJust, isNothing)
+import Data.Monoid (Any (..))
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Word (Word8, Word16, Word32, Word64)
+import Test.Tasty
+import Test.Tasty.QuickCheck hiding ((.&.))
+import Test.QuickCheck.Instances ()
+
+import Language.Ginger.AST
+import Language.Ginger.Interpret
+import Language.Ginger.Interpret.DefEnv (htmlEncode)
+import Language.Ginger.Render
+import Language.Ginger.TestUtils
+import Language.Ginger.Value
+import Language.Ginger.SourcePosition
+
+tests :: TestTree
+tests = testGroup "Language.Ginger.Interpret"
+ [ testGroup "misc"
+ [ testProperty "setVar lookupVar" prop_setVarLookupVar
+ , testProperty "scoped vars disappear outside" prop_scopedVarsDisappear
+ , testProperty "no bottoms in expression eval" (prop_noBottoms @Expr)
+ , testProperty "no bottoms in statement eval" (prop_noBottoms @Statement)
+ ]
+ , testGroup "stringify"
+ [ testProperty "string stringifies to self" prop_stringifyString
+ , testProperty "None stringifies to empty" prop_stringifyNone
+ , testProperty "Integer stringifies to show instance" (prop_stringifyShow @Integer Proxy)
+ , testProperty "Int stringifies to show instance" (prop_stringifyShow @Int Proxy)
+ , testProperty "Int8 stringifies to show instance" (prop_stringifyShow @Int8 Proxy)
+ , testProperty "Int16 stringifies to show instance" (prop_stringifyShow @Int16 Proxy)
+ , testProperty "Int32 stringifies to show instance" (prop_stringifyShow @Int32 Proxy)
+ , testProperty "Int64 stringifies to show instance" (prop_stringifyShow @Int64 Proxy)
+ , testProperty "Word stringifies to show instance" (prop_stringifyShow @Word Proxy)
+ , testProperty "Word8 stringifies to show instance" (prop_stringifyShow @Word8 Proxy)
+ , testProperty "Word16 stringifies to show instance" (prop_stringifyShow @Word16 Proxy)
+ , testProperty "Word32 stringifies to show instance" (prop_stringifyShow @Word32 Proxy)
+ , testProperty "Word64 stringifies to show instance" (prop_stringifyShow @Word64 Proxy)
+ , testProperty "Double stringifies to show instance" (prop_stringifyShow @Double Proxy)
+ -- Not testing this for Float, because converting a Float to a Double
+ -- doesn't always give the same results as @show@ing the Float directly.
+ -- , testProperty "Float stringifies to show instance" (prop_stringifyShow @Float Proxy)
+ ]
+ , testGroup "Expr"
+ [ testGroup "literals"
+ [ testProperty "None literal" (prop_literal (\() -> NoneE))
+ , testProperty "Bool literal" (prop_literal BoolE)
+ , testProperty "Integer literal" (prop_literal IntLitE)
+ , testProperty "Double literal" (prop_literal FloatLitE)
+ , testProperty "String literal" (prop_literalWith Text.pack StringLitE)
+ , testProperty "List literal" (prop_literal (ListE . fmap IntLitE))
+ , testProperty "Dict literal" (prop_literal (DictE . map (\(k, v) -> (IntLitE k, IntLitE v)) . Map.toList))
+ ]
+ , testGroup "UnaryE"
+ [ testProperty "Integer negation" (prop_unop @Integer UnopNegate negate)
+ , testProperty "Double negation" (prop_unop @Double UnopNegate negate)
+ , testProperty "Boolean not" (prop_unop @Bool UnopNot not)
+ ]
+ , testGroup "SliceE"
+ [ testProperty "List at start" prop_sliceListStart
+ , testProperty "List at end" prop_sliceListEnd
+ , testProperty "List both sides" prop_sliceListBoth
+ , testProperty "String at start" prop_sliceStringStart
+ , testProperty "String at end" prop_sliceStringEnd
+ , testProperty "String both sides" prop_sliceStringBoth
+ , testProperty "Bytes at start" prop_sliceBytesStart
+ , testProperty "Bytes at end" prop_sliceBytesEnd
+ , testProperty "Bytes both sides" prop_sliceBytesBoth
+ ]
+ , testGroup "BinaryE"
+ [ testProperty "Integer addition" (prop_binop @Integer BinopPlus (+))
+ , testProperty "Integer subtraction" (prop_binop @Integer BinopMinus (-))
+ , testProperty "Integer multiplication" (prop_binop @Integer BinopMul (*))
+ , testProperty "Integer division" (prop_binopCond @Integer Just justNonzero BinopIntDiv div)
+ , testProperty "Integer division by zero" prop_intDivByZero
+ , testProperty "Integer modulo" (prop_binopCond @Integer Just justNonzero BinopMod mod)
+ , testProperty "Integer power" (prop_binopCond @Integer @Integer justPositive justPositive BinopPower (^))
+
+ , testProperty "Double addition" (prop_binop @Double BinopPlus (+))
+ , testProperty "Double subtraction" (prop_binop @Double BinopMinus (-))
+ , testProperty "Double multiplication" (prop_binop @Double BinopMul (*))
+ , testProperty "Double division" (prop_binopCond @Double Just justNonzero BinopDiv (/))
+ , testProperty "Double division by zero" prop_divByZero
+ , testProperty "Double division to NaN" prop_divToNaN
+ , testProperty "Double power" (prop_binopCond @Double justPositive Just BinopPower (**))
+
+ , testProperty "Integer equal" (prop_binop @Integer BinopEqual (==))
+ , testProperty "Integer not equal" (prop_binop @Integer BinopNotEqual (/=))
+ , testProperty "Integer greater-than" (prop_binop @Integer BinopGT (>))
+ , testProperty "Integer greater-than-equal" (prop_binop @Integer BinopGTE (>=))
+ , testProperty "Integer less-than" (prop_binop @Integer BinopLT (<))
+ , testProperty "Integer less-than-equal" (prop_binop @Integer BinopLTE (<=))
+
+ , testProperty "Double equal" (prop_binop @Double BinopEqual (==))
+ , testProperty "Double not equal" (prop_binop @Double BinopNotEqual (/=))
+ , testProperty "Double greater-than" (prop_binop @Double BinopGT (>))
+ , testProperty "Double greater-than-equal" (prop_binop @Double BinopGTE (>=))
+ , testProperty "Double less-than" (prop_binop @Double BinopLT (<))
+ , testProperty "Double less-than-equal" (prop_binop @Double BinopLTE (<=))
+
+ , testProperty "Boolean and" (prop_binop @Bool BinopAnd (&&))
+ , testProperty "Boolean or" (prop_binop @Bool BinopOr (||))
+
+ , testProperty "String equal" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopEqual (==))
+ , testProperty "String not equal" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopNotEqual (/=))
+ , testProperty "String greater-than" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopGT (>))
+ , testProperty "String greater-than-equal" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopGTE (>=))
+ , testProperty "String less-than" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopLT (<))
+ , testProperty "String less-than-equal" (prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopLTE (<=))
+
+ , testProperty "List membership Word8" (prop_binop @Word8 @[Word8] BinopIn elem)
+ , testProperty "Dict membership Word8" (prop_binop @Word8 @(Map Word8 Word8) BinopIn (Map.member))
+ , testProperty "List index Word8" (prop_binop @[Word8] @Word8 BinopIndex (flip $ safeAt . fromIntegral))
+ , testProperty "Dict index Word8" (prop_binop @(Map Word8 Word8) @Word8 BinopIndex (flip Map.lookup))
+ , testProperty "List index (Word8/Integer)" (prop_binop @[Integer] @Word8 BinopIndex (flip $ safeAt . fromIntegral))
+ , testProperty "Dict index (Word8/Integer)" (prop_binop @(Map Word8 Integer) @Word8 BinopIndex (flip Map.lookup))
+
+ , testProperty "Bytes concatenation" $
+ prop_binopCond @ByteString (Just . BS.pack) (Just . BS.pack) BinopConcat (<>)
+ , testProperty "String concatenation" $
+ prop_binopCond @Text (Just . Text.pack) (Just . Text.pack) BinopConcat (<>)
+ , testProperty "Int concatenation" $
+ prop_binop @Int @Int @Text BinopConcat (\a b -> Text.show a <> Text.show b)
+ ]
+ , testGroup "CallE"
+ [ testProperty "Native nullary" prop_nativeNullary
+ , testProperty "Native identity" prop_nativeIdentity
+ , testProperty "User nullary" prop_userNullary
+ , testProperty "Namespace set/get" prop_namespaceSetGet
+ ]
+ , testProperty "TernaryE" prop_ternary
+ , testGroup "VarE"
+ [ testProperty "existing variable" prop_var
+ , testProperty "nonexisting variable" prop_varNeg
+ ]
+ , testGroup "FilterE"
+ [ testProperty "even" $
+ prop_eval (\i -> FilterE (IntLitE i) (VarE "even") [] []) (BoolV . even)
+ , testProperty "odd" $
+ prop_eval (\i -> FilterE (IntLitE i) (VarE "odd") [] []) (BoolV . odd)
+ , testProperty "upper string" $
+ prop_eval (\(ArbitraryText t) -> FilterE (StringLitE t) (VarE "upper") [] [])
+ (\(ArbitraryText t) -> StringV . Text.toUpper $ t)
+ , testProperty "upper int" $
+ prop_eval (\i -> FilterE (IntLitE i) (VarE "upper") [] [])
+ (StringV . Text.show)
+ , testProperty "int from string" $
+ prop_eval (\i -> FilterE (StringLitE $ Text.show i) (VarE "int") [] [])
+ IntV
+ , testProperty "int from int" $
+ prop_eval (\i -> FilterE (IntLitE i) (VarE "int") [] [])
+ IntV
+ , testProperty "int from float" $
+ prop_eval (\i -> FilterE (FloatLitE $ fromIntegral i + 0.25) (VarE "int") [] [])
+ IntV
+ , testProperty "float from string" $
+ prop_eval (\i -> FilterE (StringLitE $ Text.show i) (VarE "float") [] [])
+ FloatV
+ , testProperty "float from float" $
+ prop_eval (\i -> FilterE (IntLitE i) (VarE "float") [] [])
+ (FloatV . fromIntegral)
+ , testProperty "float from int" $
+ prop_eval (\i -> FilterE (FloatLitE i) (VarE "float") [] [])
+ FloatV
+ , testProperty "list from list" $
+ prop_eval (\xs -> FilterE (ListE $ fmap IntLitE xs) (VarE "list") [] [])
+ (ListV . fmap IntV)
+ , testProperty "list from string" $
+ prop_eval (\(ArbitraryText txt) ->
+ FilterE (StringLitE txt) (VarE "list") [] []
+ )
+ (\(ArbitraryText txt) ->
+ ListV . V.fromList . map (StringV . Text.singleton) . Text.unpack $ txt
+ )
+ , testGroup "filesizeformat"
+ [ testProperty "bytes" $
+ prop_eval
+ (\(i :: Word8) ->
+ FilterE (IntLitE $ fromIntegral i) (VarE "filesizeformat") [] []
+ )
+ (\i -> StringV $ Text.show i <> "B")
+ , testProperty "whole kilobytes" $
+ prop_eval
+ (\(i :: Word8) ->
+ FilterE (IntLitE $ fromIntegral i * 1000 + 1000) (VarE "filesizeformat") [] []
+ )
+ (\i -> StringV $ Text.show (fromIntegral i + 1 :: Int) <> ".0kB")
+ , testProperty "fractional kilobytes" $
+ prop_eval
+ (\(i :: Word8, j :: Word8) ->
+ FilterE (IntLitE $ fromIntegral i * 1000 + 1000 + fromIntegral j) (VarE "filesizeformat") [] []
+ )
+ (\(i, j) ->
+ StringV $
+ Text.show (fromIntegral i + 1 :: Int) <> "." <>
+ Text.show (j `div` 100) <>
+ "kB"
+ )
+ , testProperty "fractional megabytes" $
+ prop_eval
+ (\(i :: Word8, j :: Word8) ->
+ FilterE (IntLitE $ fromIntegral i * 1000000 + 1000000 + fromIntegral j * 1000) (VarE "filesizeformat") [] []
+ )
+ (\(i, j) ->
+ StringV $
+ Text.show (fromIntegral i + 1 :: Int) <> "." <>
+ Text.show (j `div` 100) <>
+ "MB"
+ )
+ , testProperty "fractional gigabytes" $
+ prop_eval
+ (\(i :: Word8, j :: Word8) ->
+ FilterE (IntLitE $ fromIntegral i * 1000000000 + 1000000000 + fromIntegral j * 1000000) (VarE "filesizeformat") [] []
+ )
+ (\(i, j) ->
+ StringV $
+ Text.show (fromIntegral i + 1 :: Int) <> "." <>
+ Text.show (j `div` 100) <>
+ "GB"
+ )
+ , testProperty "fractional kibibytes" $
+ prop_eval
+ (\(i :: Word8, j :: Word8) ->
+ FilterE
+ (IntLitE $ fromIntegral i * 1024 + 1024 + fromIntegral j)
+ (VarE "filesizeformat")
+ [TrueE]
+ []
+ )
+ (\(i, j) ->
+ StringV $
+ Text.show (fromIntegral i + 1 :: Int) <> "." <>
+ Text.show (fromIntegral j * 1000 `div` 102400 :: Int) <>
+ "kiB"
+ )
+ ]
+ , testProperty "length (string)" $
+ prop_eval
+ (\(ArbitraryText t) ->
+ FilterE (StringLitE t) (VarE "length") [] []
+ )
+ (\(ArbitraryText t) -> toValue (Text.length t))
+ , testProperty "length (list)" $
+ prop_eval
+ (\(PositiveInt i) ->
+ FilterE (ListE $ V.replicate i NoneE) (VarE "length") [] []
+ )
+ (\(PositiveInt i) -> toValue i)
+ , testProperty "length (dict)" $
+ prop_eval
+ (\(PositiveInt (i :: Integer)) ->
+ FilterE
+ (DictE
+ [(StringLitE $ "item" <> Text.show n, NoneE) | n <- [1..i]])
+ (VarE "length")
+ [] []
+ )
+ (\(PositiveInt i) -> toValue i)
+
+ , testGroup "escape"
+ [ testProperty "string" $
+ prop_eval
+ (\(ArbitraryText t) ->
+ FilterE (StringLitE t) (VarE "escape") [] []
+ )
+ (\(ArbitraryText t) ->
+ EncodedV (htmlEncode t)
+ )
+ , testProperty "int" $
+ prop_eval
+ (\i ->
+ FilterE (IntLitE i) (VarE "escape") [] []
+ )
+ (\i ->
+ EncodedV (Encoded $ Text.show i)
+ )
+ ]
+
+ , testGroup "first"
+ [ testProperty "list" $
+ prop_eval
+ (\(x, xs) ->
+ FilterE (ListE (IntLitE x `V.cons` fmap IntLitE xs)) (VarE "first") [] []
+ )
+ (\(x, _) ->
+ IntV x
+ )
+ , testProperty "empty list" $
+ prop_eval
+ (\() ->
+ FilterE (ListE mempty) (VarE "first") [] []
+ )
+ (\() ->
+ NoneV
+ )
+ , testProperty "string" $
+ prop_eval
+ (\(x, ArbitraryText xs) ->
+ FilterE (StringLitE (Text.singleton x <> xs)) (VarE "first") [] []
+ )
+ (\(x, _) ->
+ StringV (Text.singleton x)
+ )
+ , testProperty "empty string" $
+ prop_eval
+ (\() ->
+ FilterE (StringLitE "") (VarE "first") [] []
+ )
+ (\() ->
+ StringV ""
+ )
+ ]
+
+ , testGroup "last"
+ [ testProperty "list" $
+ prop_eval
+ (\(x, xs) ->
+ FilterE (ListE (fmap IntLitE (xs `V.snoc` x))) (VarE "last") [] []
+ )
+ (\(x, _) ->
+ IntV x
+ )
+ , testProperty "empty list" $
+ prop_eval
+ (\() ->
+ FilterE (ListE mempty) (VarE "last") [] []
+ )
+ (\() ->
+ NoneV
+ )
+ , testProperty "string" $
+ prop_eval
+ (\(x, ArbitraryText xs) ->
+ FilterE (StringLitE (xs <> Text.singleton x)) (VarE "last") [] []
+ )
+ (\(x, _) ->
+ StringV (Text.singleton x)
+ )
+ , testProperty "empty string" $
+ prop_eval
+ (\() ->
+ FilterE (StringLitE "") (VarE "last") [] []
+ )
+ (\() ->
+ StringV ""
+ )
+ ]
+
+ , testProperty "dictsort" $
+ prop_eval
+ (\items ->
+ FilterE
+ (DictE $
+ [ (StringLitE k, StringLitE v)
+ | (NonEmptyText k, ArbitraryText v)
+ <- items
+ ]
+ )
+ (VarE "dictsort")
+ []
+ [(Identifier "case_sensitive", TrueE)]
+ )
+ (\items ->
+ toValue $
+ sortOn fst
+ [ (k, v)
+ | (NonEmptyText k, ArbitraryText v)
+ <- Map.toAscList . Map.fromList $ items
+ ]
+ )
+
+ , testGroup "map"
+ [ testProperty "map(string)" $
+ prop_eval
+ (\xs ->
+ FilterE
+ (ListE (fmap IntLitE xs))
+ (VarE "map")
+ [VarE "string"]
+ []
+ )
+ (\xs ->
+ ListV (fmap (StringV . Text.show) xs)
+ )
+ , testProperty "map('string')" $
+ prop_eval
+ (\xs ->
+ FilterE
+ (ListE (fmap IntLitE xs))
+ (VarE "map")
+ [StringLitE "string"]
+ []
+ )
+ (\xs ->
+ ListV (fmap (StringV . Text.show) xs)
+ )
+ , testProperty "map(center, width)" $
+ prop_eval
+ (\(xs, PositiveInt n) ->
+ FilterE
+ (ListE $ fmap (StringLitE . unArbitraryText) xs)
+ (VarE "map")
+ [VarE "center"]
+ [("width", IntLitE n)]
+ )
+ (\(xs :: Vector ArbitraryText, PositiveInt n) ->
+ let w = fromInteger n
+ in
+ ListV $ V.map (\(ArbitraryText t) ->
+ if Text.length t >= w then
+ StringV t
+ else
+ let p = w - Text.length t
+ pL = p `div` 2
+ pR = p - pL
+ in StringV (Text.replicate pL " " <> t <> Text.replicate pR " ")
+ ) xs
+ )
+ , testProperty "map('center', width)" $
+ prop_eval
+ (\(xs, PositiveInt n) ->
+ FilterE
+ (ListE $ fmap (StringLitE . unArbitraryText) xs)
+ (VarE "map")
+ [StringLitE "center"]
+ [("width", IntLitE n)]
+ )
+ (\(xs :: Vector ArbitraryText, PositiveInt n) ->
+ let w = fromInteger n
+ in
+ ListV $ V.map (\(ArbitraryText t) ->
+ if Text.length t >= w then
+ StringV t
+ else
+ let p = w - Text.length t
+ pL = p `div` 2
+ pR = p - pL
+ in StringV (Text.replicate pL " " <> t <> Text.replicate pR " ")
+ ) xs
+ )
+ , testProperty "map(attribute=)" $
+ prop_eval
+ (\(xs, name) ->
+ FilterE
+ (ListE $
+ fmap
+ (\x ->
+ DictE
+ [(StringLitE $ identifierName name, IntLitE x)])
+ xs
+ )
+ (VarE "map")
+ []
+ [("attribute", StringLitE $ identifierName name)]
+ )
+ (\(xs, _) ->
+ ListV (fmap IntV xs)
+ )
+ , testProperty "map(attribute=x, default=y)" $
+ prop_eval
+ (\(xs, name, otherName, ArbitraryText dummyVal, ArbitraryText defval) ->
+ FilterE
+ (ListE . V.fromList $ intersperse
+ (DictE [(StringLitE $ identifierName otherName, StringLitE dummyVal)])
+ [ DictE [(StringLitE $ identifierName name, IntLitE x)]
+ | x <- V.toList xs
+ ])
+ (VarE "map")
+ []
+ [ ("attribute", StringLitE $ identifierName name)
+ , ("default", StringLitE defval)
+ ]
+ )
+ (\(xs, _, _, _, ArbitraryText defval) ->
+ ListV . V.fromList $ intersperse (StringV defval) (V.toList $ fmap IntV xs)
+ )
+ ]
+
+ , testGroup "sort"
+ [ testProperty "strings, simple" $
+ prop_eval
+ (\xs ->
+ FilterE
+ (ListE $ fmap (StringLitE . unArbitraryText) xs)
+ (VarE "sort")
+ []
+ [ ("case_sensitive", TrueE)
+ ]
+ )
+ (\xs ->
+ ListV $ fmap (StringV . unArbitraryText) (V.fromList . sort . V.toList $ xs)
+ )
+ , testProperty "strings, reverse" $
+ prop_eval
+ (\xs ->
+ FilterE
+ (ListE $ fmap (StringLitE . unArbitraryText) xs)
+ (VarE "sort")
+ []
+ [ ("case_sensitive", TrueE)
+ , ("reverse", TrueE)
+ ]
+ )
+ (\xs ->
+ ListV $ fmap (StringV . unArbitraryText) (V.reverse . V.fromList . sort . V.toList $ xs)
+ )
+ ]
+
+ , testGroup "join"
+ [ testProperty "simple" $
+ prop_eval
+ (\(ArbitraryText t, ArbitraryText u) ->
+ FilterE (ListE [StringLitE t, StringLitE u]) (VarE "join") [] []
+ )
+ (\(ArbitraryText t, ArbitraryText u) ->
+ StringV (t <> u)
+ )
+ , testProperty "ints" $
+ prop_eval
+ (\(i, j) ->
+ FilterE (ListE [IntLitE i, IntLitE j]) (VarE "join") [] []
+ )
+ (\(i, j) ->
+ StringV (Text.show i <> Text.show j)
+ )
+ , testProperty "with sep" $
+ prop_eval
+ (\(ArbitraryText t, ArbitraryText u, ArbitraryText v, ArbitraryText s) ->
+ FilterE
+ (ListE [StringLitE t, StringLitE u, StringLitE v])
+ (VarE "join")
+ [StringLitE s]
+ []
+ )
+ (\(ArbitraryText t, ArbitraryText u, ArbitraryText v, ArbitraryText s) ->
+ StringV (t <> s <> u <> s <> v)
+ )
+ ]
+ , testGroup "default"
+ [ testProperty "undefined" $
+ prop_eval (\i -> FilterE (VarE "something_undefined") (VarE "default") [(IntLitE i)] []) IntV
+ , testProperty "none" $
+ prop_eval (\i -> FilterE NoneE (VarE "default") [(IntLitE i)] []) IntV
+ , testProperty "boolean false" $
+ prop_eval (\i -> FilterE FalseE (VarE "default") [(IntLitE i)] []) (const FalseV)
+ , testProperty "boolean false, boolean mode" $
+ prop_eval (\i -> FilterE FalseE (VarE "default") [(IntLitE i), TrueE] []) IntV
+ ]
+ , testGroup "strip"
+ [ testProperty "string" $
+ prop_eval (\(ArbitraryText t) ->
+ FilterE (StringLitE t) (VarE "strip") [] []
+ )
+ (\(ArbitraryText t) ->
+ StringV (Text.strip t)
+ )
+ ]
+ , testGroup "center string"
+ [ testProperty "width as vararg" $
+ prop_eval (\((ArbitraryText t), w) ->
+ FilterE (StringLitE t) (VarE "center") [IntLitE $ fromIntegral w] []
+ )
+ (\((ArbitraryText t), w) ->
+ if Text.length t >= w then
+ StringV t
+ else
+ let p = w - Text.length t
+ pL = p `div` 2
+ pR = p - pL
+ in StringV $ Text.replicate pL " " <> t <> Text.replicate pR " "
+ )
+ , testProperty "width as kwarg" $
+ prop_eval (\((ArbitraryText t), w) ->
+ FilterE (StringLitE t) (VarE "center") [] [("width", IntLitE $ fromIntegral w)]
+ )
+ (\((ArbitraryText t), w) ->
+ if Text.length t >= w then
+ StringV t
+ else
+ let p = w - Text.length t
+ pL = p `div` 2
+ pR = p - pL
+ in StringV $ Text.replicate pL " " <> t <> Text.replicate pR " "
+ )
+ ]
+ , testGroup "round"
+ [ testProperty "precision 0" $
+ prop_eval
+ (\(PositiveInt i) ->
+ FilterE
+ (FloatLitE $ fromIntegral i / 10)
+ (VarE "round")
+ []
+ [("precision", IntLitE 0), ("method", StringLitE "floor")]
+ )
+ (\(PositiveInt i) ->
+ FloatV . fromIntegral $ (i `div` 10 :: Integer)
+ )
+ , testProperty "precision 2, floor" $
+ prop_eval
+ (\(PositiveInt i) ->
+ FilterE
+ (FloatLitE $ fromIntegral i / 1000)
+ (VarE "round")
+ []
+ [("precision", IntLitE 2), ("method", StringLitE "floor")]
+ )
+ (\(PositiveInt i) ->
+ FloatV $ fromIntegral (i `div` 10 :: Integer) / 100
+ )
+ ]
+
+ , testProperty "items" $
+ prop_eval
+ (\pairs ->
+ FilterE
+ (DictE [ (StringLitE k, StringLitE v) | (ArbitraryText k, ArbitraryText v) <- pairs ])
+ (VarE "items")
+ [] []
+ )
+ (\pairs ->
+ ListV . V.fromList $
+ [ ListV [StringV k, StringV v]
+ | (ArbitraryText k, ArbitraryText v) <- Map.toAscList . Map.fromList $ pairs
+ ])
+
+ , testProperty "batch" $
+ prop_eval
+ (\(PositiveInt i, PositiveInt j) ->
+ FilterE (ListE (V.replicate (i * j) NoneE)) (VarE "batch") [IntLitE $ fromIntegral j] [])
+ (\(PositiveInt i, PositiveInt j) ->
+ ListV (V.replicate i (ListV (V.replicate j NoneV))))
+ , testProperty "batch with fill" $
+ prop_eval
+ (\(PositiveInt i, PositiveInt j, PositiveInt x, f) ->
+ FilterE
+ (ListE (V.replicate (i * j + x `mod` j) NoneE))
+ (VarE "batch")
+ [IntLitE $ fromIntegral j, IntLitE f]
+ []
+ )
+ (\(PositiveInt i, PositiveInt j, PositiveInt x, f) ->
+ ListV (
+ V.replicate i (ListV (V.replicate j NoneV)) <>
+ if x `mod` j == 0 then
+ mempty
+ else
+ V.singleton $
+ ListV
+ ( V.replicate (x `mod` j) NoneV
+ <> V.replicate (j - x `mod` j) (IntV f)
+ )
+ )
+ )
+
+ -- TODO:
+ -- regex module
+ -- split
+ -- reverse
+ -- dateformat
+
+ ]
+ , testGroup "DotE"
+ [ testGroup "StringV"
+ [ testProperty "string length" $
+ prop_attr "length"
+ (\(ArbitraryText t) -> StringLitE t)
+ (\(ArbitraryText t) -> Text.length t)
+ , testProperty "upper string" $
+ prop_string_method "upper" (const []) Text.toUpper
+ , testProperty "lower string" $
+ prop_string_method "lower" (const []) Text.toLower
+ , testProperty "capitalize string" $
+ prop_string_method "capitalize" (const []) Text.toTitle
+ , testProperty "title string" $
+ prop_string_method "title" (const []) Text.toTitle
+ , testProperty "casefold string" $
+ prop_string_method "casefold" (const []) Text.toCaseFold
+ , testProperty "string isalpha" $
+ prop_method "isalpha"
+ (\(ArbitraryText t) -> StringLitE (Text.filter isAlpha t))
+ (const [])
+ (\(ArbitraryText t) -> if Text.null (Text.filter isAlpha t) then TrueV else TrueV)
+ , testProperty "string isalnum" $
+ prop_method "isalnum"
+ (\(ArbitraryText t) -> StringLitE (Text.filter isAlphaNum t))
+ (const [])
+ (\(ArbitraryText t) -> if Text.null (Text.filter isAlphaNum t) then TrueV else TrueV)
+ , testProperty "string isascii" $
+ prop_method "isascii"
+ (\(ArbitraryByteString chars) ->
+ StringLitE . Text.pack . map (chr . fromIntegral . (.&. 0x7F)) $ BS.unpack chars
+ )
+ (const [])
+ (const TrueV)
+ , testProperty "string isascii" $
+ prop_method "isascii"
+ (\(ArbitraryByteString chars) ->
+ StringLitE . Text.pack . (++ [chr 128]) . map (chr . fromIntegral . (.&. 0x7F)) $ BS.unpack chars
+ )
+ (const [])
+ (const FalseV)
+ , testProperty "count string" $
+ prop_method "count"
+ (\(NonEmptyText t, NonEmptyText f, PositiveInt p) ->
+ StringLitE (Text.intercalate f . replicate (fromIntegral p) $ t)
+ )
+ (\(NonEmptyText t, NonEmptyText _, PositiveInt _) ->
+ [ StringLitE t ]
+ )
+ (\(NonEmptyText t, NonEmptyText f, PositiveInt p) ->
+ -- The second part accounts for cases where the needle (t) is a
+ -- substring of the filler (f).
+ IntV $
+ p + (fromIntegral (Text.count t f) * (p - 1))
+ )
+ , testProperty "center string" $
+ prop_method "center"
+ (\(ArbitraryText t, _) -> StringLitE t)
+ (\(ArbitraryText t, PositiveInt p) -> [IntLitE (p + p + fromIntegral (Text.length t))])
+ (\(ArbitraryText t, PositiveInt p) ->
+ let padding = Text.replicate (fromInteger p) " "
+ in StringV $ padding <> t <> padding
+ )
+ , testProperty "center string with fillchar" $
+ prop_method "center"
+ (\(ArbitraryText t, _, _) -> StringLitE t)
+ (\(ArbitraryText t, PositiveInt p, c) ->
+ [ IntLitE (p + p + fromIntegral (Text.length t))
+ , StringLitE (Text.singleton c)
+ ])
+ (\(ArbitraryText t, PositiveInt p, c) ->
+ let padding = Text.replicate (fromInteger p) (Text.singleton c)
+ in StringV $ padding <> t <> padding
+ )
+ , testProperty "encode string (UTF-8)" $
+ prop_method "encode"
+ (\(ArbitraryText t) -> StringLitE t)
+ (const [])
+ (\(ArbitraryText t) -> BytesV . Text.encodeUtf8 $ t)
+ , testProperty "encode string (UTF-16LE)" $
+ prop_method "encode"
+ (\(ArbitraryText t) -> StringLitE t)
+ (const [StringLitE "utf-16-LE"])
+ (\(ArbitraryText t) -> BytesV . Text.encodeUtf16LE $ t)
+ , testProperty "encode string (UTF-16BE)" $
+ prop_method "encode"
+ (\(ArbitraryText t) -> StringLitE t)
+ (const [StringLitE "utf-16-BE"])
+ (\(ArbitraryText t) -> BytesV . Text.encodeUtf16BE $ t)
+ , testProperty "encode string (UTF-32LE)" $
+ prop_method "encode"
+ (\(ArbitraryText t) -> StringLitE t)
+ (const [StringLitE "utf-32-LE"])
+ (\(ArbitraryText t) -> BytesV . Text.encodeUtf32LE $ t)
+ , testProperty "encode string (UTF-32BE)" $
+ prop_method "encode"
+ (\(ArbitraryText t) -> StringLitE t)
+ (const [StringLitE "utf-32-BE"])
+ (\(ArbitraryText t) -> BytesV . Text.encodeUtf32BE $ t)
+ , testProperty "encode string (ASCII)" $
+ prop_method "encode"
+ (\(ArbitraryByteString b) -> StringLitE (Text.decodeUtf8 $ BS.filter (< 128) b))
+ (const [StringLitE "ASCII"])
+ (\(ArbitraryByteString b) -> BytesV (BS.filter (< 128) b))
+ , testProperty "string startswith" $
+ prop_method "startswith"
+ (\(NonEmptyText needle, NonEmptyText p) -> StringLitE (needle <> p))
+ (\(NonEmptyText needle, _) -> [StringLitE needle])
+ (\_ -> TrueV)
+ , testProperty "string startswith ranged" $
+ prop_method "startswith"
+ (\(NonEmptyText needle, NonEmptyText p, NonEmptyText b, NonEmptyText a) ->
+ StringLitE (b <> needle <> p <> a))
+ (\(NonEmptyText needle, NonEmptyText p, NonEmptyText b, _) ->
+ [ StringLitE needle
+ , IntLitE . fromIntegral $ Text.length b
+ , IntLitE . fromIntegral $ Text.length b + Text.length needle + Text.length p
+ ]
+ )
+ (\_ -> TrueV)
+ , testProperty "string endswith" $
+ prop_method "endswith"
+ (\(NonEmptyText needle, NonEmptyText p) -> StringLitE (p <> needle))
+ (\(NonEmptyText needle, _) -> [StringLitE needle])
+ (\_ -> TrueV)
+ , testProperty "string split (no sep)" $
+ prop_method "split"
+ (\(NonEmptyText _sep, NonEmptyText item) ->
+ StringLitE item
+ )
+ (\(NonEmptyText sep, NonEmptyText _item) ->
+ [StringLitE sep]
+ )
+ (\(NonEmptyText sep, NonEmptyText item) ->
+ if sep `Text.isInfixOf` item then
+ ListV (fmap StringV . V.fromList $ Text.splitOn sep item)
+ else
+ ListV $ V.singleton (StringV item)
+ )
+ , testProperty "string split" $
+ prop_method "split"
+ (\(NonEmptyText sep, NonEmptyText item, PositiveInt i) ->
+ StringLitE (Text.intercalate sep $ replicate (i + 1) item)
+ )
+ (\(NonEmptyText sep, NonEmptyText _item, PositiveInt _i) ->
+ [StringLitE sep]
+ )
+ (\(NonEmptyText sep, NonEmptyText item, PositiveInt i) ->
+ if sep `Text.isInfixOf` item then
+ ListV $ V.concat $ replicate (i + 1) (fmap StringV . V.fromList $ Text.splitOn sep item)
+ else
+ ListV $ V.replicate (i + 1) (StringV item)
+ )
+ , testProperty "string splitlines" $
+ prop_method "splitlines"
+ (\(NonEmptyText item, PositiveInt i) ->
+ StringLitE (Text.unlines $ replicate i (Text.filter (not . isControl) item))
+ )
+ (const [])
+ (\(NonEmptyText item, PositiveInt i) ->
+ ListV $ V.replicate i (StringV (Text.filter (not . isControl) item))
+ )
+ , testProperty "string join" $
+ prop_method "join"
+ (\(NonEmptyText sep, NonEmptyText _item, PositiveInt _i) ->
+ StringLitE sep
+ )
+ (\(NonEmptyText _sep, NonEmptyText item, PositiveInt i) ->
+ [ListE $ V.replicate i (StringLitE item)]
+ )
+ (\(NonEmptyText sep, NonEmptyText item, PositiveInt i) ->
+ StringV $ Text.intercalate sep $ replicate i item
+ )
+
+ , testProperty "string replace" $
+ prop_method "replace"
+ (\() ->
+ StringLitE "Hello, world!"
+ )
+ (const [StringLitE "world", StringLitE "Tobias"])
+ (\() ->
+ StringV "Hello, Tobias!"
+ )
+ , testProperty "string replace limited 1" $
+ prop_method "replace"
+ (\() ->
+ StringLitE "Hello, world! How are you!"
+ )
+ (const [StringLitE "!", StringLitE "?", IntLitE 1])
+ (\() ->
+ StringV "Hello, world? How are you!"
+ )
+ , testProperty "string replace limited 2" $
+ prop_method "replace"
+ (\() ->
+ StringLitE "Hello, world! How are you!"
+ )
+ (const [StringLitE "!", StringLitE "?", IntLitE 3])
+ (\() ->
+ StringV "Hello, world? How are you?"
+ )
+
+ , testProperty "string strip" $
+ prop_method "strip"
+ (\(NonEmptyText item, PositiveInt i, PositiveInt j) ->
+ StringLitE (Text.replicate i " " <> item <> Text.replicate j " ")
+ )
+ (const [])
+ (\(NonEmptyText item, _, _) ->
+ StringV (Text.strip item)
+ )
+ , testProperty "string lstrip" $
+ prop_method "lstrip"
+ (\(NonEmptyText item, PositiveInt i, PositiveInt j) ->
+ StringLitE (Text.replicate i " " <> item <> Text.replicate j " ")
+ )
+ (const [])
+ (\(NonEmptyText item, _, PositiveInt j) ->
+ if Text.all isSpace item then
+ StringV ""
+ else
+ StringV (Text.stripStart item <> Text.replicate j " ")
+ )
+ , testProperty "string rstrip" $
+ prop_method "rstrip"
+ (\(NonEmptyText item, PositiveInt i, PositiveInt j) ->
+ StringLitE (Text.replicate i " " <> item <> Text.replicate j " ")
+ )
+ (const [])
+ (\(NonEmptyText item, PositiveInt i, _) ->
+ if Text.all isSpace item then
+ StringV ""
+ else
+ StringV (Text.replicate i " " <> Text.stripEnd item)
+ )
+ ]
+ ]
+ , testGroup "IsE"
+ [ testGroup "defined"
+ [ testProperty "is defined true" prop_isDefinedTrue
+ , testProperty "is defined false" prop_isDefinedFalse
+ , testProperty "is defined dict" prop_isDefinedTrueDict
+ ]
+ , testGroup "boolean"
+ [ testProperty "boolean is boolean" $ prop_is @Bool "boolean" True
+ , testProperty "integer is not boolean" $ prop_is @Integer "boolean" False
+ , testProperty "float is not boolean" $ prop_is @Double "boolean" False
+ , testProperty "none is not boolean" $ prop_is @() "boolean" False
+ , testProperty "text is not boolean" $ prop_is @ArbitraryText "boolean" False
+ , testProperty "list is not boolean" $ prop_is @[Bool] "boolean" False
+ , testProperty "dict is not boolean" $ prop_is @(Map Bool Bool) "boolean" False
+ ]
+ , testGroup "integer"
+ [ testProperty "boolean is not int" $ prop_is @Bool "integer" False
+ , testProperty "integer is int" $ prop_is @Integer "integer" True
+ , testProperty "float is not int" $ prop_is @Double "integer" False
+ , testProperty "none is not int" $ prop_is @() "integer" False
+ , testProperty "text is not int" $ prop_is @ArbitraryText "integer" False
+ , testProperty "list is not int" $ prop_is @[Bool] "integer" False
+ , testProperty "dict is not int" $ prop_is @(Map Bool Bool) "integer" False
+ ]
+ , testGroup "float"
+ [ testProperty "boolean is not float" $ prop_is @Bool "float" False
+ , testProperty "integer is not float" $ prop_is @Integer "float" False
+ , testProperty "float is float" $ prop_is @Double "float" True
+ , testProperty "none is not float" $ prop_is @() "float" False
+ , testProperty "text is not float" $ prop_is @ArbitraryText "float" False
+ , testProperty "list is not float" $ prop_is @[Bool] "float" False
+ , testProperty "dict is not float" $ prop_is @(Map Bool Bool) "float" False
+ ]
+ , testGroup "none"
+ [ testProperty "boolean is not none" $ prop_is @Bool "none" False
+ , testProperty "integer is not none" $ prop_is @Integer "none" False
+ , testProperty "float is none" $ prop_is @Double "none" False
+ , testProperty "none is none" $ prop_is @() "none" True
+ , testProperty "text is not none" $ prop_is @ArbitraryText "none" False
+ , testProperty "list is not none" $ prop_is @[Bool] "none" False
+ , testProperty "dict is not none" $ prop_is @(Map Bool Bool) "none" False
+ ]
+ , testGroup "true"
+ [ testProperty "integer is not true" $ prop_is @Integer "true" False
+ , testProperty "float is true" $ prop_is @Double "true" False
+ , testProperty "none is not true" $ prop_is @() "true" False
+ , testProperty "text is not true" $ prop_is @ArbitraryText "true" False
+ , testProperty "list is not true" $ prop_is @[Bool] "true" False
+ , testProperty "dict is not true" $ prop_is @(Map Bool Bool) "true" False
+ ]
+ , testGroup "false"
+ [ testProperty "integer is not false" $ prop_is @Integer "false" False
+ , testProperty "float is false" $ prop_is @Double "false" False
+ , testProperty "none is not false" $ prop_is @() "false" False
+ , testProperty "text is not false" $ prop_is @ArbitraryText "false" False
+ , testProperty "list is not false" $ prop_is @[Bool] "false" False
+ , testProperty "dict is not false" $ prop_is @(Map Bool Bool) "false" False
+ ]
+ , testGroup "filter"
+ [ testProperty "even is filter" $ prop_is "filter" True (StringV "even" :: Value Identity)
+ , testProperty "default is filter" $ prop_is "filter" True (StringV "default" :: Value Identity)
+ , testProperty "number is not filter" $ prop_is "filter" False (StringV "number" :: Value Identity)
+ , testProperty "true is not filter" $ prop_is "filter" False (StringV "true" :: Value Identity)
+ , testProperty "none is not filter" $ prop_is "filter" False (StringV "none" :: Value Identity)
+ ]
+ , testGroup "test"
+ [ testProperty "even is test" $ prop_is "test" True (StringV "even" :: Value Identity)
+ , testProperty "default is not test" $ prop_is "test" False (StringV "default" :: Value Identity)
+ , testProperty "number is test" $ prop_is "test" True (StringV "number" :: Value Identity)
+ , testProperty "true is test" $ prop_is "test" True (StringV "true" :: Value Identity)
+ , testProperty "none is test" $ prop_is "test" True (StringV "none" :: Value Identity)
+ ]
+ ]
+ ]
+ , testGroup "Statement"
+ [ testProperty "Immediate statement outputs itself" prop_immediateStatementOutput
+ , testProperty "Interpolation statement outputs its argument" prop_interpolationStatementOutput
+ , testProperty "Comment statement outputs None" prop_commentStatementOutput
+ , testProperty "IfS outputs the correct branch" prop_ifStatementOutput
+ , testGroup "ForS"
+ [ testProperty "simple loop" prop_forStatementSimple
+ , testProperty "simple loop with key" prop_forStatementWithKey
+ , testProperty "with else branch" prop_forStatementEmpty
+ , testProperty "with filter" prop_forStatementFilter
+ , testProperty "loop object" prop_forStatementLoopVars
+ , testProperty "using namespace object" prop_forStatementNamespace
+ ]
+ , testGroup "CallS"
+ [ testProperty "no args" prop_callNoArgs
+ , testProperty "identity" prop_callIdentity
+ , testProperty "echo" prop_callEcho
+ , testProperty "ginger macro" prop_callMacro
+ ]
+ , testGroup "FilterS"
+ [
+ ]
+ , testGroup "IncludeS"
+ [ testProperty "plain" prop_include
+ , testProperty "into" prop_includeInto
+ , testProperty "macro" prop_includeMacro
+ , testProperty "macro without context" prop_includeMacroWithoutContext
+ , testProperty "set" prop_includeSet
+ , testProperty "without context" prop_includeWithoutContext
+ , testProperty "with context" prop_includeWithContext
+ ]
+ , testGroup "ImportS"
+ [ testProperty "value" prop_importValue
+ , testProperty "macro" prop_importMacro
+ , testProperty "alias" prop_importValueAlias
+ , testProperty "with context" prop_importWithContext
+ , testProperty "without context" prop_importWithoutContext
+ , testProperty "explicit" prop_importExplicit
+ ]
+ , testGroup "extends"
+ [ testProperty "simple" prop_extendSimple
+ , testProperty "super" prop_extendSuper
+ , testProperty "with context" prop_extendWithContext
+ , testProperty "without context" prop_extendWithoutContext
+ ]
+ ]
+ ]
+
+prop_noBottoms :: (Eval Identity a, Arbitrary a) => a -> Bool
+prop_noBottoms e =
+ runGingerIdentityEither (eval e) `seq` True
+
+isProcedure :: Value m -> Bool
+isProcedure ProcedureV {} = True
+isProcedure _ = False
+
+prop_setVarLookupVar :: Identifier -> Value Identity -> Property
+prop_setVarLookupVar k v =
+ let (w, equal) = runGingerIdentity program
+
+ program :: GingerT Identity (Value Identity, Bool)
+ program = do
+ setVar k v
+ v' <- lookupVar k
+ (,) <$> pure v' <*> valuesEqual v v'
+ in
+ -- exclude procedures, because we cannot compare those
+ (not . getAny) (traverseValue (Any . isProcedure) v) ==>
+ counterexample (show w)
+ (equal === True)
+
+prop_stringifyString :: String -> Property
+prop_stringifyString str =
+ let expected = Text.pack str
+ actual = runGingerIdentity (stringify (StringV expected))
+ in
+ expected === actual
+
+prop_stringifyNone :: Property
+prop_stringifyNone =
+ runGingerIdentity (stringify NoneV) === ""
+
+prop_stringifyShow :: (ToValue a Identity, Show a) => Proxy a -> a -> Property
+prop_stringifyShow _ i =
+ let expected = Text.show i
+ actual = runGingerIdentity (stringify $ toValue i)
+ in
+ expected === actual
+
+prop_scopedVarsDisappear :: (Identifier, Value Identity)
+ -> (Identifier, Value Identity)
+ -> Property
+prop_scopedVarsDisappear (name1, val1) (name2, val2) =
+ name1 /= name2 ==>
+ property . runGingerIdentity $ do
+ setVar name1 val1
+ exists1a <- isJust <$> lookupVarMaybe name1
+ exists2 <- scoped $ do
+ setVar name2 val2
+ isJust <$> lookupVarMaybe name2
+ exists1c <- isJust <$> lookupVarMaybe name1
+ notExists2 <- isNothing <$> lookupVarMaybe name2
+ pure $ V.and [ exists1a, exists1c, exists2, notExists2 ]
+
+--------------------------------------------------------------------------------
+-- Expression properties
+--------------------------------------------------------------------------------
+
+prop_sliceListStart :: [Int]
+ -> Int
+ -> Property
+prop_sliceListStart items start =
+ let expected = if start < 0 then
+ toValue $ drop (length items + start) items
+ else
+ toValue $ drop start items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ eval (SliceE (VarE "items") (Just $ VarE "start") Nothing)
+ in
+ actual === expected
+
+prop_sliceListEnd :: [Int]
+ -> Int
+ -> Property
+prop_sliceListEnd items end =
+ let expected = if end < 0 then
+ toValue $ take (length items + end) items
+ else
+ toValue $ take end items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") Nothing (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_sliceListBoth :: [Int]
+ -> Int
+ -> Int
+ -> Property
+prop_sliceListBoth items start end =
+ let start' = if start < 0 then length items + start else start
+ end' = if end < 0 then length items - start' + end else end
+ expected = toValue . take end' . drop start' $ items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") (Just $ VarE "start") (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_sliceStringStart :: ArbitraryText
+ -> Int
+ -> Property
+prop_sliceStringStart (ArbitraryText items) start =
+ let expected = if start < 0 then
+ toValue $ Text.drop (Text.length items + start) items
+ else
+ toValue $ Text.drop start items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ eval (SliceE (VarE "items") (Just $ VarE "start") Nothing)
+ in
+ actual === expected
+
+prop_sliceStringEnd :: ArbitraryText
+ -> Int
+ -> Property
+prop_sliceStringEnd (ArbitraryText items) end =
+ let expected = if end < 0 then
+ toValue $ Text.take (Text.length items + end) items
+ else
+ toValue $ Text.take end items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") Nothing (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_sliceStringBoth :: ArbitraryText
+ -> Int
+ -> Int
+ -> Property
+prop_sliceStringBoth (ArbitraryText items) start end =
+ let start' = if start < 0 then Text.length items + start else start
+ end' = if end < 0 then Text.length items - start' + end else end
+ expected = toValue . Text.take end' . Text.drop start' $ items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") (Just $ VarE "start") (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_sliceBytesStart :: ArbitraryByteString
+ -> Int
+ -> Property
+prop_sliceBytesStart (ArbitraryByteString items) start =
+ let expected = if start < 0 then
+ toValue $ BS.drop (BS.length items + start) items
+ else
+ toValue $ BS.drop start items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ eval (SliceE (VarE "items") (Just $ VarE "start") Nothing)
+ in
+ actual === expected
+
+prop_sliceBytesEnd :: ArbitraryByteString
+ -> Int
+ -> Property
+prop_sliceBytesEnd (ArbitraryByteString items) end =
+ let expected = if end < 0 then
+ toValue $ BS.take (BS.length items + end) items
+ else
+ toValue $ BS.take end items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") Nothing (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_sliceBytesBoth :: ArbitraryByteString
+ -> Int
+ -> Int
+ -> Property
+prop_sliceBytesBoth (ArbitraryByteString items) start end =
+ let start' = if start < 0 then BS.length items + start else start
+ end' = if end < 0 then BS.length items - start' + end else end
+ expected = toValue . BS.take end' . BS.drop start' $ items
+ actual = runGingerIdentity $ do
+ setVar "items" (toValue items)
+ setVar "start" (toValue start)
+ setVar "end" (toValue end)
+ eval (SliceE (VarE "items") (Just $ VarE "start") (Just $ VarE "end"))
+ in
+ actual === expected
+
+prop_unop :: (ToValue a Identity, ToValue b Identity)
+ => UnaryOperator
+ -> (a -> b)
+ -> a
+ -> Property
+prop_unop = prop_unopCond Just
+
+prop_unopCond :: (ToValue a' Identity, ToValue b Identity)
+ => (a -> Maybe a')
+ -> UnaryOperator
+ -> (a' -> b)
+ -> a
+ -> Property
+prop_unopCond fX unop f x' =
+ let x = fX x'
+ resultG = runGingerIdentity $ do
+ setVar "a" (toValue x)
+ eval (UnaryE unop (VarE "a"))
+ resultH = toValue $ f <$> x
+ in
+ isJust x ==>
+ resultG === resultH
+
+prop_binop :: (ToValue a Identity, ToValue b Identity, ToValue c Identity)
+ => BinaryOperator
+ -> (a -> b -> c)
+ -> a
+ -> b
+ -> Property
+prop_binop = prop_binopCond Just Just
+
+prop_binopCond :: (ToValue a' Identity, ToValue b' Identity, ToValue c Identity)
+ => (a -> Maybe a')
+ -> (b -> Maybe b')
+ -> BinaryOperator
+ -> (a' -> b' -> c)
+ -> a
+ -> b
+ -> Property
+prop_binopCond fX fY binop f x' y' =
+ let x = fX x'
+ y = fY y'
+ resultG = runGingerIdentity $ do
+ setVar "a" (toValue x)
+ setVar "b" (toValue y)
+ eval (BinaryE binop (VarE "a") (VarE "b"))
+ resultH = toValue $ f <$> x <*> y
+ in
+ isJust x ==>
+ isJust y ==>
+ resultG === resultH
+
+prop_intDivByZero :: Integer -> Property
+prop_intDivByZero i =
+ let result = runGingerIdentityEither $ do
+ setVar "i" (toValue i)
+ eval (BinaryE BinopIntDiv (IntLitE i) (IntLitE 0))
+ in
+ i /= 0 ==>
+ result === leftPRE (NumericError "//" "division by zero")
+
+prop_divByZero :: Double -> Property
+prop_divByZero d =
+ let result = runGingerIdentityEither $ do
+ setVar "d" (toValue d)
+ eval (BinaryE BinopDiv (FloatLitE d) (FloatLitE 0))
+ in
+ d /= 0 ==>
+ result === leftPRE (NumericError "/" "division by zero")
+
+prop_divToNaN :: Property
+prop_divToNaN =
+ let result = runGingerIdentityEither $ do
+ eval (BinaryE BinopDiv (FloatLitE 0) (FloatLitE 0))
+ in
+ result === leftPRE (NumericError "/" "not a number")
+
+prop_literal :: ToValue a Identity => (a -> Expr) -> a -> Property
+prop_literal = prop_literalWith id
+
+prop_literalWith :: ToValue b Identity => (a -> b) -> (b -> Expr) -> a -> Property
+prop_literalWith f mkExpr val =
+ let expr = mkExpr (f val)
+ result = runGingerIdentity (eval expr)
+ in
+ result === toValue (f val)
+
+prop_ternary :: Bool -> Integer -> Integer -> Property
+prop_ternary cond yes no =
+ let expr = TernaryE (BoolE cond) (IntLitE yes) (IntLitE no)
+ resultG = runGingerIdentity (eval expr)
+ resultH = if cond then yes else no
+ in
+ resultG === toValue resultH
+
+prop_var :: Identifier -> Integer -> Property
+prop_var name val =
+ let expr = VarE name
+ resultG = runGingerIdentity (setVar name (toValue val) >> eval expr)
+ in
+ resultG === toValue val
+
+prop_varNeg :: Identifier -> Integer -> Identifier -> Property
+prop_varNeg name1 val1 name2 =
+ let expr = VarE name2
+ resultG = runGingerIdentityEither (setVar name1 (toValue val1) >> eval expr)
+ in
+ name1 /= name2 ==>
+ resultG === leftPRE (NotInScopeError (identifierName name2))
+
+prop_nativeNullary :: Identifier -> Integer -> Property
+prop_nativeNullary varName constVal =
+ let fVal = ProcedureV . NativeProcedure "testsuite:nativeNullary" Nothing $
+ const . const . pure @Identity . Right . toValue $ constVal
+ expr = CallE (VarE varName) [] []
+ result = runGingerIdentity (setVar varName fVal >> eval expr)
+ in
+ result === toValue constVal
+
+prop_nativeIdentity :: Identifier -> Identifier -> Integer -> Property
+prop_nativeIdentity varName argVarName arg =
+ let fVal = fnToValue
+ "testsuite:nativeIdentity"
+ Nothing
+ (id :: Value Identity -> Value Identity)
+ argVal = toValue arg
+ expr = CallE (VarE varName) [VarE argVarName] []
+ result = runGingerIdentity $ do
+ setVar varName fVal
+ setVar argVarName argVal
+ eval expr
+ in
+ counterexample (show fVal) $
+ counterexample (show argVal) $
+ varName /= argVarName ==>
+ result === argVal
+
+prop_userNullary :: Identifier -> Expr -> Property
+prop_userNullary varName bodyExpr =
+ let fVal = ProcedureV $ GingerProcedure mempty [] bodyExpr
+ resultCall = runGingerIdentityEither $ do
+ setVar varName fVal
+ eval $ CallE (VarE varName) [] []
+ resultDirect = runGingerIdentityEither $ do
+ eval bodyExpr
+ in
+ resultCall === resultDirect
+
+prop_namespaceSetGet :: Identifier -> Identifier -> Integer -> Property
+prop_namespaceSetGet nsName attrName val =
+ let program = GroupS
+ [ PositionedS (SourcePosition "test" 1 1) $
+ SetS (SetVar nsName) (CallE (VarE "namespace") [] [])
+ , PositionedS (SourcePosition "test" 2 1) $
+ SetS (SetMutable nsName attrName) (IntLitE val)
+ , PositionedS (SourcePosition "test" 3 1) $
+ InterpolationS (DotE (VarE nsName) attrName)
+ ]
+ result = runGingerIdentity $ eval program
+ in
+ counterexample (Text.unpack $ renderSyntaxText program) $
+ result === IntV val
+
+prop_isDefinedTrue :: Identifier -> Integer -> Property
+prop_isDefinedTrue name val =
+ let result = runGingerIdentity $ do
+ setVar name (toValue val)
+ eval $ IsE (VarE name) (VarE "defined") [] []
+ in
+ result === TrueV
+
+prop_isDefinedFalse :: Identifier -> Property
+prop_isDefinedFalse name =
+ let result = runGingerIdentity $ do
+ eval $ IsE (VarE name) (VarE "defined") [] []
+ in
+ not (name `Map.member` envVars (defEnv @Identity)) ==>
+ result === FalseV
+
+prop_isDefinedTrueDict :: Identifier -> Identifier -> Integer -> Property
+prop_isDefinedTrueDict name selector val =
+ let result = runGingerIdentity $ do
+ setVar name (dictV [toScalar (identifierName selector) .= val])
+ eval $ IsE (IndexE (VarE name) (StringLitE $ identifierName selector)) (VarE "defined") [] []
+ in
+ result === TrueV
+
+prop_is :: ToValue a Identity => Identifier -> Bool -> a -> Property
+prop_is testName expected val =
+ let testE = case testName of
+ "none" -> NoneE
+ "true" -> TrueE
+ "false" -> FalseE
+ t -> VarE t
+ result = runGingerIdentity $ do
+ setVar "v" (toValue val)
+ eval $ IsE (VarE "v") testE [] []
+ in
+ result === BoolV expected
+
+prop_eval :: (Arbitrary a, Show a, Show e, Eval Identity e) => (a -> e) -> (a -> Value Identity) -> a -> Property
+prop_eval mkEvaluable mkExpected x =
+ let e = mkEvaluable x
+ expected = mkExpected x
+ result = runGingerIdentity $ eval e
+ in
+ counterexample (show e) $
+ result === expected
+
+prop_attr :: (Arbitrary a, Show a, ToValue b Identity)
+ => Identifier
+ -> (a -> Expr)
+ -> (a -> b)
+ -> a
+ -> Property
+prop_attr methodName mkSelf mkExpected =
+ prop_eval (\t' -> DotE (mkSelf t') methodName)
+ (toValue . mkExpected)
+
+prop_method :: (Arbitrary a, Show a)
+ => Identifier
+ -> (a -> Expr)
+ -> (a -> [Expr])
+ -> (a -> Value Identity)
+ -> a
+ -> Property
+prop_method methodName mkSelf mkArgs mkExpected t =
+ counterexample (show $ mkArgs t) $
+ prop_eval (\t' -> CallE (DotE (mkSelf t) methodName) (mkArgs t') [])
+ mkExpected
+ t
+
+prop_string_method :: Identifier
+ -> (Text -> [Expr])
+ -> (Text -> Text)
+ -> ArbitraryText
+ -> Property
+prop_string_method methodName mkArgs mkExpected =
+ prop_method methodName
+ (\(ArbitraryText t) -> StringLitE t)
+ (\(ArbitraryText t) -> mkArgs t)
+ (\(ArbitraryText t) -> StringV . mkExpected $ t)
+
+--------------------------------------------------------------------------------
+-- Statement properties
+--------------------------------------------------------------------------------
+
+prop_immediateStatementOutput :: Encoded -> Property
+prop_immediateStatementOutput str =
+ let stmt = ImmediateS str
+ result = runGingerIdentity (eval stmt)
+ in
+ result === EncodedV str
+
+prop_commentStatementOutput :: String -> Property
+prop_commentStatementOutput str =
+ let stmt = CommentS (Text.pack str)
+ result = runGingerIdentity (eval stmt)
+ in
+ result === NoneV
+
+prop_interpolationStatementOutput :: Expr -> Property
+prop_interpolationStatementOutput expr =
+ let resultS = runGingerIdentityEither (eval $ InterpolationS expr)
+ resultE = runGingerIdentityEither (eval expr)
+ in
+ isRight resultE ==>
+ either (const True) (not . getAny . traverseValue (Any . isProcedure)) resultE ==>
+ resultS === resultE
+
+prop_ifStatementOutput :: Bool -> Statement -> Statement -> Property
+prop_ifStatementOutput cond yes no =
+ let resultYes = runGingerIdentityEither (eval yes)
+ resultNo = runGingerIdentityEither (eval no)
+ resultE = if cond then resultYes else resultNo
+ resultIf = runGingerIdentityEither (eval $ IfS (BoolE cond) yes (Just no))
+ hasProcedure = case resultE of
+ Left _ -> False
+ Right v -> getAny (traverseValue (Any . isProcedure) v)
+ in
+ -- exclude procedures, because we cannot compare those
+ not hasProcedure ==>
+ resultIf === resultE
+
+prop_forStatementSimple :: Identifier -> Identifier -> [String] -> Property
+prop_forStatementSimple itereeName varName strItems =
+ let items = ListV . V.fromList $ map (StringV . Text.pack) strItems
+ expected = StringV . Text.pack . mconcat $ strItems
+ resultFor = runGingerIdentity $ do
+ setVar itereeName items
+ eval $ ForS
+ Nothing -- loop key var
+ varName-- loop value var
+ (VarE itereeName) -- iteree
+ Nothing -- loop condition
+ NotRecursive
+ (InterpolationS (VarE varName)) -- loop body
+ Nothing -- empty body
+ in
+ not (null strItems) ==>
+ resultFor === expected
+
+prop_forStatementWithKey :: Identifier -> Identifier -> Identifier -> [String] -> Property
+prop_forStatementWithKey itereeName varName keyName strItems =
+ let items = ListV . V.fromList $ map (StringV . Text.pack) strItems
+ expected = StringV . Text.pack . mconcat $
+ [ show k ++ v | (k, v) <- zip [(0 :: Int) ..] strItems ]
+ resultFor = runGingerIdentity $ do
+ setVar itereeName items
+ eval $ ForS
+ (Just keyName) -- loop key var
+ varName-- loop value var
+ (VarE itereeName) -- iteree
+ Nothing -- loop condition
+ NotRecursive
+ (GroupS
+ [ InterpolationS (VarE keyName)
+ , InterpolationS (VarE varName)
+ ]
+ ) -- loop body
+ Nothing -- empty body
+ in
+ varName /= keyName ==>
+ not (null strItems) ==>
+ resultFor === expected
+
+prop_forStatementEmpty :: Statement -> Property
+prop_forStatementEmpty body =
+ let resultDirect = runGingerIdentityEither (eval body)
+ resultFor = runGingerIdentityEither
+ (eval $ ForS
+ Nothing
+ "item"
+ (ListE [])
+ Nothing
+ NotRecursive
+ (InterpolationS (VarE "item"))
+ (Just body)
+ )
+ in
+ resultFor === resultDirect
+
+prop_forStatementFilter :: [Integer] -> Property
+prop_forStatementFilter intItems =
+ let items = ListV . V.fromList $ map IntV intItems
+ expected = StringV . Text.pack . mconcat $ [ show i | i <- intItems, i > 0 ]
+ resultFor = runGingerIdentity $ do
+ setVar "items" items
+ eval $ ForS
+ Nothing
+ "item"
+ (VarE "items") -- iteree
+ (Just $ BinaryE BinopGT (VarE "item") (IntLitE 0))
+ NotRecursive
+ (InterpolationS (VarE "item"))
+ Nothing
+ in
+ length (filter (> 0) intItems) > 1 ==>
+ resultFor === expected
+
+prop_forStatementLoopVars :: [Integer] -> Property
+prop_forStatementLoopVars intItems =
+ let items = ListV . V.fromList $ map IntV intItems
+ expected = StringV . Text.pack . mconcat $
+ [ show (succ i) ++ show (i :: Int) ++ show v
+ | (i, v) <- zip [0..] intItems
+ ]
+ resultFor = runGingerIdentity $ do
+ setVar "items" items
+ eval $ ForS
+ Nothing
+ "item"
+ (VarE "items") -- iteree
+ Nothing
+ NotRecursive
+ (GroupS
+ [ InterpolationS (BinaryE BinopIndex (VarE "loop") (StringLitE "index"))
+ , InterpolationS (BinaryE BinopIndex (VarE "loop") (StringLitE "index0"))
+ , InterpolationS (VarE "item")
+ ]
+ )
+ Nothing
+ in
+ not (null intItems) ==>
+ resultFor === expected
+
+prop_forStatementNamespace :: [Integer] -> Property
+prop_forStatementNamespace intItems =
+ let items = ListV . V.fromList $ map IntV intItems
+ expected = IntV $ sum intItems
+ program = GroupS
+ [ SetS (SetVar "ns") (CallE (VarE "namespace") [] [])
+ , SetS (SetMutable "ns" "sum") (IntLitE 0)
+ , ForS
+ Nothing
+ "item"
+ (VarE "items") -- iteree
+ Nothing
+ NotRecursive
+ (GroupS
+ [ SetS (SetMutable "ns" "sum") $
+ PlusE (DotE (VarE "ns") "sum") (VarE "item")
+ ]
+ )
+ Nothing
+ , InterpolationS (DotE (VarE "ns") "sum")
+ ]
+ resultFor = runGingerIdentity $ do
+ setVar "items" items
+ eval program
+ in
+ counterexample (Text.unpack $ renderSyntaxText program) $
+ not (null intItems) ==>
+ resultFor === expected
+
+prop_callNoArgs :: Expr -> Property
+prop_callNoArgs body =
+ let resultDirect = runGingerIdentityEither $ do
+ eval body
+ resultCall = runGingerIdentityEither $ do
+ setVar "f" $ ProcedureV (GingerProcedure mempty [] body)
+ eval $ CallS "f" [] [] (InterpolationS NoneE)
+ cat = case resultDirect of
+ Right {} -> "OK"
+ Left err -> unwords . take 1 . words $ show err
+ in
+ label cat $
+ either (const True) (not . getAny . traverseValue (Any . isProcedure)) resultDirect ==>
+ resultCall === resultDirect
+
+prop_callIdentity :: Expr -> Property
+prop_callIdentity body =
+ -- Some trickery is needed to make sure that if anything inside @body@
+ -- references a variable @f@, it points to the same thing in both cases.
+ let body' = StatementE $ GroupS
+ [ SetS (SetVar "f") NoneE
+ , InterpolationS body
+ ]
+ resultDirect = runGingerIdentityEither $
+ eval body'
+ resultCall = runGingerIdentityEither $ do
+ setVar "f" $
+ fnToValue
+ "testsuite:callIdentity"
+ Nothing
+ (id :: Value Identity -> Value Identity)
+ eval $ CallS "f" [body'] [] (InterpolationS NoneE)
+ cat = case resultDirect of
+ Right {} -> "OK"
+ Left err -> unwords . take 1 . words $ show err
+ in
+ label cat $
+ either (const True) (not . getAny . traverseValue (Any . isProcedure)) resultDirect ==>
+ resultCall === resultDirect
+
+prop_callEcho :: Expr -> Property
+prop_callEcho body =
+ -- Some trickery is needed to make sure that if anything inside @body@
+ -- references a variable @f@, it points to the same thing in both cases.
+ let body' = GroupS
+ [ SetS (SetVar "f") NoneE
+ , InterpolationS body
+ ]
+ resultDirect = runGingerIdentityEither $
+ eval body'
+ resultCall = runGingerIdentityEither $ do
+ env <- gets evalEnv
+ setVar "f" $
+ ProcedureV $
+ GingerProcedure env [] $ CallE (VarE "caller") [] []
+ eval $ CallS "f" [] [] body'
+ cat = case resultDirect of
+ Right {} -> "OK"
+ Left err -> unwords . take 1 . words $ show err
+ in
+ label cat $
+ either (const True) (not . getAny . traverseValue (Any . isProcedure)) resultDirect ==>
+ resultCall === resultDirect
+
+prop_callMacro :: Statement -> Property
+prop_callMacro body =
+ -- Some trickery is needed to make sure that if anything inside @body@
+ -- references a variable @f@, it points to the same thing in both cases.
+ let body' = GroupS
+ [ SetS (SetVar "f") NoneE
+ , body
+ ]
+ resultDirect = runGingerIdentityEither $
+ eval $ GroupS
+ [ ImmediateS $ Encoded "Hello, "
+ , body'
+ ]
+ resultCall = runGingerIdentityEither $
+ eval $
+ GroupS
+ [ MacroS "f" [] $ GroupS
+ [ ImmediateS $ Encoded "Hello, "
+ , InterpolationS (CallE (VarE "caller") [] [])
+ ]
+ , CallS "f" [] [] body'
+ ]
+ cat = case resultDirect of
+ Right {} -> "OK"
+ Left err -> unwords . take 1 . words $ show err
+ in
+ label cat $
+ either (const True) (not . getAny . traverseValue (Any . isProcedure)) resultDirect ==>
+ resultCall === resultDirect
+
+prop_include :: ArbitraryText -> Statement -> Property
+prop_include (ArbitraryText name) body =
+ let bodySrc = renderSyntaxText body
+ resultDirect = runGingerIdentityEither $
+ eval body
+ loader = mockLoader [(name, bodySrc)]
+ includeS = IncludeS (StringLitE name) RequireMissing WithContext
+ includeSrc = renderSyntaxText includeS
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval includeS
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("INCLUDER:\n" ++ Text.unpack includeSrc) $
+ isRight resultDirect ==>
+ resultInclude === resultDirect
+
+prop_includeInto :: ArbitraryText -> Statement -> Statement -> Property
+prop_includeInto (ArbitraryText name) body parent =
+ let bodySrc = renderSyntaxText body
+ resultDirect = runGingerIdentityEither $
+ eval (GroupS [ body, parent ])
+ loader = mockLoader [(name, bodySrc)]
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval (
+ GroupS
+ [ IncludeS (StringLitE name) RequireMissing WithContext
+ , parent
+ ])
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ isRight resultDirect ==>
+ resultInclude === resultDirect
+
+prop_includeMacro :: ArbitraryText -> Identifier -> Statement -> Property
+prop_includeMacro (ArbitraryText name) macroName body =
+ let bodySrc = renderSyntaxText $
+ MacroS macroName [] body
+ resultDirect = runGingerIdentityEither $
+ eval body
+ loader = mockLoader [(name, bodySrc)]
+ includeS = GroupS
+ [ IncludeS (StringLitE name) RequireMissing WithContext
+ , CallS macroName [] [] (InterpolationS NoneE)
+ ]
+ includeSrc = renderSyntaxText includeS
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval includeS
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("INCLUDER:\n" ++ Text.unpack includeSrc) $
+ isRight resultDirect ==>
+ resultInclude === resultDirect
+
+prop_includeMacroWithoutContext :: ArbitraryText -> Identifier -> Statement -> Property
+prop_includeMacroWithoutContext (ArbitraryText name) macroName body =
+ let bodySrc = renderSyntaxText $
+ MacroS macroName [] body
+ resultDirect = runGingerIdentityEither $
+ eval body
+ loader = mockLoader [(name, bodySrc)]
+
+ includeS = GroupS
+ [ IncludeS (StringLitE name) RequireMissing WithoutContext
+ , CallS macroName [] [] (InterpolationS NoneE)
+ ]
+ includeSrc = renderSyntaxText includeS
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval includeS
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("INCLUDER:\n" ++ Text.unpack includeSrc) $
+ name /= identifierName macroName ==>
+ isRight resultDirect ==>
+ resultInclude === resultDirect
+
+prop_includeSet :: ArbitraryText -> Identifier -> ArbitraryText -> Property
+prop_includeSet (ArbitraryText name) varName (ArbitraryText varValue) =
+ let bodySrc = renderSyntaxText $
+ SetS (SetVar varName) (StringLitE varValue)
+ resultDirect = runGingerIdentityEither $
+ eval (StringLitE varValue)
+ loader = mockLoader [(name, bodySrc)]
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval (
+ GroupS
+ [ IncludeS (StringLitE name) RequireMissing WithContext
+ , InterpolationS (VarE varName)
+ ]
+ )
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ resultInclude === resultDirect
+
+prop_includeWithContext :: ArbitraryText -> Identifier -> ArbitraryText -> Property
+prop_includeWithContext (ArbitraryText name) varName (ArbitraryText varValue) =
+ let bodySrc = renderSyntaxText $
+ InterpolationS (VarE varName)
+ resultDirect = runGingerIdentityEither $
+ eval (StringLitE varValue)
+ loader = mockLoader [(name, bodySrc)]
+ includeS = GroupS
+ [ SetS (SetVar varName) (StringLitE varValue)
+ , IncludeS (StringLitE name) RequireMissing WithContext
+ ]
+ includeSrc = renderSyntaxText includeS
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval includeS
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("INCLUDER:\n" ++ Text.unpack includeSrc) $
+ resultInclude === resultDirect
+
+prop_includeWithoutContext :: ArbitraryText -> Identifier -> ArbitraryText -> Property
+prop_includeWithoutContext (ArbitraryText name) varName (ArbitraryText varValue) =
+ let bodySrc = renderSyntaxText $
+ InterpolationS (VarE varName)
+ loader = mockLoader [(name, bodySrc)]
+ includeS = GroupS
+ [ SetS (SetVar varName) (StringLitE varValue)
+ , IncludeS (StringLitE name) RequireMissing WithoutContext
+ ]
+ includeSrc = renderSyntaxText includeS
+ resultInclude = runGingerIdentityEitherWithLoader loader $
+ eval includeS
+ expected = Left . PrettyRuntimeError $ NotInScopeError (identifierName varName)
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("INCLUDER:\n" ++ Text.unpack includeSrc) $
+ resultInclude === expected
+
+prop_importValue :: ArbitraryText -> Identifier -> Expr -> Property
+prop_importValue (ArbitraryText name) varName valE =
+ let bodySrc = renderSyntaxText (SetS (SetVar varName) valE)
+ resultDirect = runGingerIdentityEither $ eval valE
+ loader = mockLoader [(name, bodySrc)]
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $
+ GroupS
+ [ ImportS (StringLitE name) Nothing Nothing RequireMissing WithoutContext
+ , InterpolationS (VarE varName)
+ ]
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ resultImport === resultDirect
+
+prop_importValueAlias :: ArbitraryText -> Identifier -> Identifier -> Expr -> Property
+prop_importValueAlias (ArbitraryText name) alias varName valE =
+ let bodySrc = renderSyntaxText (SetS (SetVar varName) valE)
+ resultDirect = runGingerIdentityEither $ eval valE
+ loader = mockLoader [(name, bodySrc)]
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $
+ GroupS
+ [ ImportS (StringLitE name) (Just alias) Nothing RequireMissing WithoutContext
+ , InterpolationS $
+ DotE
+ (VarE alias)
+ varName
+ ]
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ isRight resultDirect ==>
+ resultImport === resultDirect
+
+prop_importMacro :: ArbitraryText -> Identifier -> Statement -> Property
+prop_importMacro (ArbitraryText name) varName bodyS =
+ let bodySrc = renderSyntaxText (MacroS varName [] bodyS)
+ resultDirect = runGingerIdentityEither $ eval bodyS
+ loader = mockLoader [(name, bodySrc)]
+ importS = GroupS
+ [ ImportS (StringLitE name) Nothing Nothing RequireMissing WithoutContext
+ , CallS varName [] [] (InterpolationS NoneE)
+ ]
+ importSrc = renderSyntaxText importS
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $ importS
+ in
+ counterexample ("BODY:\n" ++ Text.unpack bodySrc) $
+ counterexample ("IMPORTER:\n" ++ Text.unpack importSrc) $
+ isRight resultDirect ==>
+ resultImport === resultDirect
+
+prop_importWithoutContext :: ArbitraryText -> Identifier -> Identifier -> Expr -> Property
+prop_importWithoutContext (ArbitraryText name) macroName varName bodyE =
+ let bodySrc = renderSyntaxText $
+ (MacroS macroName []
+ (InterpolationS
+ (VarE varName)))
+ resultDirect = runGingerIdentityEither $ do
+ void $ eval bodyE
+ throwError $ NotInScopeError (identifierName varName)
+ loader = mockLoader [(name, bodySrc)]
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $
+ GroupS
+ [ SetS (SetVar varName) bodyE
+ , ImportS (StringLitE name) Nothing Nothing RequireMissing WithoutContext
+ , CallS macroName [] [] (InterpolationS NoneE)
+ ]
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ macroName /= varName ==>
+ resultImport === resultDirect
+
+prop_importWithContext :: ArbitraryText -> Identifier -> Identifier -> Expr -> Property
+prop_importWithContext (ArbitraryText name) macroName varName bodyE =
+ let bodySrc = renderSyntaxText $
+ (MacroS macroName []
+ (InterpolationS
+ (VarE varName)))
+ resultDirect = runGingerIdentityEither $ eval bodyE
+ loader = mockLoader [(name, bodySrc)]
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $
+ GroupS
+ [ SetS (SetVar varName) bodyE
+ , ImportS (StringLitE name) Nothing Nothing RequireMissing WithContext
+ , CallS macroName [] [] (InterpolationS NoneE)
+ ]
+ in
+ counterexample ("SOURCE:\n" ++ Text.unpack bodySrc) $
+ macroName /= varName ==>
+ resultImport === resultDirect
+
+prop_importExplicit :: NonEmptyText
+ -> Identifier -> Expr
+ -> Identifier -> Expr
+ -> Expr
+ -> Property
+prop_importExplicit (NonEmptyText name)
+ varName1 body1E
+ varName2 body2E
+ body3E =
+ let bodySrc = renderSyntaxText $
+ GroupS
+ [ SetS (SetVar varName1) body1E
+ , SetS (SetVar varName2) body2E
+ ]
+ directS = GroupS
+ [ InterpolationS body2E
+ , InterpolationS body3E
+ ]
+ resultDirect = runGingerIdentityEither $ do
+ void $ eval $ InterpolationS body3E
+ void $ eval $ InterpolationS body1E
+ eval $ directS
+ directSrc = renderSyntaxText $ directS
+
+ loader = mockLoader [(name, bodySrc)]
+ mainS = GroupS
+ [ SetS (SetVar varName1) body3E
+ , ImportS (StringLitE name) Nothing (Just [(varName2, Nothing)]) RequireMissing WithoutContext
+ , InterpolationS (VarE varName2)
+ , InterpolationS (VarE varName1)
+ ]
+ resultImport = runGingerIdentityEitherWithLoader loader . eval $ mainS
+ importerSrc = renderSyntaxText $ mainS
+ in
+ counterexample ("DIRECT SOURCE:\n" ++ Text.unpack directSrc) $
+ counterexample ("IMPORTED SOURCE:\n" ++ Text.unpack bodySrc) $
+ counterexample ("MAIN SOURCE:\n" ++ Text.unpack importerSrc) $
+ varName1 /= varName2 ==>
+ resultImport === resultDirect
+
+prop_extendSimple :: NonEmptyText
+ -> Identifier
+ -> Statement
+ -> Statement
+ -> Property
+prop_extendSimple (NonEmptyText parentName) blockName body body' =
+ let parentSrc = renderSyntaxText $
+ GroupS
+ [ ImmediateS (Encoded "foo\n")
+ , BlockS blockName (Block body NotScoped Optional)
+ , ImmediateS (Encoded "bar\n")
+ ]
+ directS = GroupS
+ [ ImmediateS (Encoded "foo\n")
+ , body'
+ , ImmediateS (Encoded "bar\n")
+ ]
+ directSrc = renderSyntaxText $
+ directS
+ mainT = Template
+ (Just parentName)
+ (BlockS blockName $ Block body' NotScoped Optional)
+ mainSrc = renderSyntaxText $
+ templateBody mainT
+ loader = mockLoader [(parentName, parentSrc)]
+ resultDirect = runGingerIdentityEither $ do
+ evalS directS
+ resultExtends = runGingerIdentityEitherWithLoader loader $ do
+ evalT mainT
+ cat = case resultDirect of
+ Left err -> unwords . take 1 . words $ show err
+ Right _ -> "OK"
+ in
+ label cat $
+ counterexample ("PARENT SOURCE:\n" ++ Text.unpack parentSrc) $
+ counterexample ("CHILD SOURCE:\n" ++ Text.unpack mainSrc) $
+ counterexample ("DIRECT SOURCE:\n" ++ Text.unpack directSrc) $
+ resultExtends === resultDirect
+
+prop_extendSuper :: NonEmptyText
+ -> Identifier
+ -> Statement
+ -> Statement
+ -> Property
+prop_extendSuper (NonEmptyText parentName) blockName body body' =
+ let parentSrc = renderSyntaxText $
+ GroupS
+ [ ImmediateS (Encoded "foo\n")
+ , BlockS blockName (Block body NotScoped Optional)
+ , ImmediateS (Encoded "bar\n")
+ ]
+ directS = GroupS
+ [ ImmediateS (Encoded "foo\n")
+ , body'
+ , body
+ , ImmediateS (Encoded "bar\n")
+ ]
+ directSrc = renderSyntaxText $
+ directS
+ mainT = Template
+ (Just parentName)
+ (BlockS blockName $
+ Block
+ (GroupS
+ [ body'
+ , CallS "super" [] [] (GroupS [])
+ ]
+ )
+ NotScoped
+ Optional)
+ mainSrc = renderSyntaxText $
+ templateBody mainT
+ loader = mockLoader [(parentName, parentSrc)]
+ resultDirect = runGingerIdentityEither $ do
+ evalS directS
+ resultExtends = runGingerIdentityEitherWithLoader loader $ do
+ evalT mainT
+ cat = case resultDirect of
+ Left err -> unwords . take 1 . words $ show err
+ Right _ -> "OK"
+ in
+ label cat $
+ counterexample ("PARENT SOURCE:\n" ++ Text.unpack parentSrc) $
+ counterexample ("CHILD SOURCE:\n" ++ Text.unpack mainSrc) $
+ counterexample ("DIRECT SOURCE:\n" ++ Text.unpack directSrc) $
+ isRight resultDirect ==>
+ resultExtends === resultDirect
+
+prop_extendWithContext :: NonEmptyText
+ -> Identifier
+ -> Identifier
+ -> Expr
+ -> Property
+prop_extendWithContext (NonEmptyText parentName) blockName varName varExpr =
+ let
+ parentS = GroupS
+ [ SetS (SetVar varName) varExpr
+ , BlockS blockName (Block (GroupS []) Scoped Optional)
+ ]
+ parentSrc = renderSyntaxText $ parentS
+
+ childT = Template
+ (Just parentName)
+ (BlockS blockName
+ (Block (InterpolationS (VarE varName)) Scoped Optional)
+ )
+ childSrc = renderSyntaxText $ childT
+
+ directS = GroupS
+ [ SetS (SetVar varName) varExpr
+ , BlockS blockName
+ (Block (InterpolationS (VarE varName)) Scoped Optional)
+ ]
+ directSrc = renderSyntaxText $ directS
+
+ loader = mockLoader [(parentName, parentSrc)]
+
+ resultDirect = runGingerIdentityEither $ do
+ evalS directS
+ resultExtends = runGingerIdentityEitherWithLoader loader $ do
+ evalT childT
+ cat = case resultDirect of
+ Left err -> unwords . take 1 . words $ show err
+ Right _ -> "OK"
+ in
+ label cat $
+ counterexample ("PARENT SOURCE:\n" ++ Text.unpack parentSrc) $
+ counterexample ("CHILD SOURCE:\n" ++ Text.unpack childSrc) $
+ counterexample ("DIRECT SOURCE:\n" ++ Text.unpack directSrc) $
+ resultExtends === resultDirect
+
+prop_extendWithoutContext :: NonEmptyText
+ -> Identifier
+ -> Identifier
+ -> Expr
+ -> Identifier
+ -> Property
+prop_extendWithoutContext (NonEmptyText parentName) blockName varName varExpr dummyVarName =
+ let
+ parentS = GroupS
+ [ SetS (SetVar varName) varExpr
+ , BlockS blockName (Block (GroupS []) NotScoped Optional)
+ ]
+ parentSrc = renderSyntaxText $ parentS
+
+ childT = Template
+ (Just parentName)
+ (BlockS blockName
+ (Block (InterpolationS (VarE varName)) NotScoped Optional)
+ )
+ childSrc = renderSyntaxText $ childT
+
+ directS = GroupS
+ [ SetS (SetVar dummyVarName) varExpr
+ , BlockS blockName
+ (Block (InterpolationS (VarE varName)) NotScoped Optional)
+ ]
+ directSrc = renderSyntaxText $ directS
+
+ loader = mockLoader [(parentName, parentSrc)]
+
+ resultDirect = runGingerIdentityEither $ do
+ evalS directS
+ resultExtends = runGingerIdentityEitherWithLoader loader $ do
+ evalT childT
+ cat = case resultDirect of
+ Left (PrettyRuntimeError (NotInScopeError n)) | Identifier n == varName -> "OK (NotInScope, expected)"
+ Left err -> unwords . take 1 . words $ show err
+ Right _ -> "Unexpected success"
+ in
+ label cat $
+ counterexample ("PARENT SOURCE:\n" ++ Text.unpack parentSrc) $
+ counterexample ("CHILD SOURCE:\n" ++ Text.unpack childSrc) $
+ counterexample ("DIRECT SOURCE:\n" ++ Text.unpack directSrc) $
+ varName /= dummyVarName ==>
+ resultExtends === resultDirect
diff --git a/test/Language/Ginger/Parse/Tests.hs b/test/Language/Ginger/Parse/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Ginger/Parse/Tests.hs
@@ -0,0 +1,569 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Language.Ginger.Parse.Tests
+where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import Text.Megaparsec (eof)
+import Test.QuickCheck.Instances ()
+
+import Language.Ginger.AST
+import Language.Ginger.Parse
+import Language.Ginger.Render
+import Language.Ginger.TestUtils
+
+tests :: TestTree
+tests = testGroup "Language.Ginger.Parse"
+ [ testGroup "Expr"
+ [ testProperty "roundTrip" (prop_parserRoundTrip exprUP id)
+ , testGroup "Simple"
+ [ testGroup "StringLitE"
+ [ testCase "simple (double-quoted)" $
+ test_parser exprUP "\"Hello\"" (StringLitE "Hello")
+ , testCase "simple (single-quoted)" $
+ test_parser exprUP "'Hello'" (StringLitE "Hello")
+ , testCase "with escapes (double-quoted)" $
+ test_parser exprUP "\"Hello\\n\\\"world\\\"\"" (StringLitE "Hello\n\"world\"")
+ , testCase "with escapes (single-quoted)" $
+ test_parser exprUP "'Hello\\n\\'world\\''" (StringLitE "Hello\n'world'")
+ ]
+ , testGroup "IntLitE"
+ [ testCase "IntLitE positive" $
+ test_parser exprUP "2134" (IntLitE 2134)
+ , testCase "IntLitE negative" $
+ test_parser exprUP "-2134" (IntLitE (-2134))
+ ]
+ , testGroup "FloatLitE"
+ [ testCase "FloatLitE positive decimal" $
+ test_parser exprUP "21.34" (FloatLitE 21.34)
+ , testCase "FloatLitE negative decimal" $
+ test_parser exprUP "-21.34" (FloatLitE (-21.34))
+ , testCase "FloatLitE positive exponential" $
+ test_parser exprUP "21.34e10" (FloatLitE 21.34e10)
+ , testCase "FloatLitE negative exponential" $
+ test_parser exprUP "-21.34e10" (FloatLitE (-21.34e10))
+ , testCase "FloatLitE positive exponential, negative exponent" $
+ test_parser exprUP "21.34e-10" (FloatLitE 21.34e-10)
+ , testCase "FloatLitE positive decimal, leading dot" $
+ test_parser exprUP ".34" (FloatLitE 0.34)
+ , testCase "FloatLitE positive decimal, trailing dot" $
+ test_parser exprUP "12." (FloatLitE 12)
+ , testCase "FloatLitE negative decimal, leading dot" $
+ test_parser exprUP "-.34" (FloatLitE (-0.34))
+ ]
+ , testGroup "NoneE"
+ [ testCase "none" $
+ test_parser exprUP "none" NoneE
+ , testCase "None (uppercase)" $
+ test_parser exprUP "None" NoneE
+ ]
+ , testGroup "BoolE"
+ [ testCase "BoolE True" $
+ test_parser exprUP "true" (BoolE True)
+ , testCase "BoolE False" $
+ test_parser exprUP "false" (BoolE False)
+ , testCase "BoolE True (uppercase)" $
+ test_parser exprUP "True" (BoolE True)
+ , testCase "BoolE False (uppercase)" $
+ test_parser exprUP "False" (BoolE False)
+ ]
+ , testGroup "VarE"
+ [ testCase "simple" $
+ test_parser exprUP "foo" (VarE "foo")
+ , testCase "parenthesized" $
+ test_parser exprUP "(foo)" (VarE "foo")
+ ]
+ ]
+ , testGroup "Unops" $
+ map
+ (\(unop, sym) ->
+ testCase (show unop) $
+ test_parser
+ exprUP
+ (sym <> " foo")
+ (UnaryE unop (VarE "foo"))
+ )
+ [ (UnopNot, "not")
+ , (UnopNegate, "-")
+ ]
+ , testGroup "Binops" $
+ map
+ (\(binop, sym) ->
+ testCase (show binop) $
+ test_parser
+ exprUP
+ ("foo " <> sym <> " bar")
+ (BinaryE binop (VarE "foo") (VarE "bar"))
+ )
+ [ (BinopPlus, "+")
+ , (BinopMinus, "-")
+ , (BinopDiv, "/")
+ , (BinopIntDiv, "//")
+ , (BinopMod, "%")
+ , (BinopMul, "*")
+ , (BinopPower, "**")
+ , (BinopEqual, "==")
+ , (BinopNotEqual, "!=")
+ , (BinopGT, ">")
+ , (BinopGTE, ">=")
+ , (BinopLT, "<")
+ , (BinopLTE, "<=")
+ , (BinopAnd, "and")
+ , (BinopOr, "or")
+ , (BinopIn, "in")
+ , (BinopConcat, "~")
+ ]
+ , testGroup "List"
+ [ testCase "empty list" $
+ test_parser exprUP "[]" (ListE mempty)
+ , testCase "single-item list" $
+ test_parser exprUP "[ 1 ] " (ListE [IntLitE 1])
+ , testCase "multi-item list" $
+ test_parser exprUP "[ 1, \"aaa\" ] " (ListE [IntLitE 1, StringLitE "aaa"])
+ , testCase "nested list" $
+ test_parser exprUP "[ [ none ], true, false ] "
+ (ListE
+ [ ListE [ NoneE ]
+ , BoolE True
+ , BoolE False
+ ])
+ ]
+ , testGroup "Dict"
+ [ testCase "empty dict" $
+ test_parser exprUP "{}" (DictE [])
+ , testCase "single-item dict" $
+ test_parser exprUP "{ 1: none } " (DictE [(IntLitE 1, NoneE)])
+ , testCase "multi-item dict" $
+ test_parser exprUP "{ foo: 1, bar: \"aaa\" } " (DictE [(VarE "foo", IntLitE 1), (VarE "bar", StringLitE "aaa")])
+ , testCase "nested dict" $
+ test_parser exprUP "{ \"a\": {}, \"b\": { \"c\": 123 }}"
+ (DictE
+ [ (StringLitE "a", DictE [])
+ , (StringLitE "b", DictE [(StringLitE "c", IntLitE 123)])
+ ])
+ ]
+ , testGroup "ternary"
+ [ testCase "simple" $
+ test_parser exprUP "foo if bar else baz"
+ (TernaryE (VarE "bar") (VarE "foo") (VarE "baz"))
+ , testCase "nested" $
+ test_parser exprUP "foo if bar else baz if quux else none"
+ (TernaryE (VarE "bar") (VarE "foo")
+ (TernaryE (VarE "quux") (VarE "baz") NoneE))
+ ]
+ , testGroup "is"
+ [ testCase "simple" $
+ test_parser exprUP "foo is bar"
+ (IsE (VarE "foo") (VarE "bar") [] [])
+ , testCase "empty arg list" $
+ test_parser exprUP "foo is bar()"
+ (IsE (VarE "foo") (VarE "bar") [] [])
+ , testCase "with arg" $
+ test_parser exprUP "foo is bar(baz)"
+ (IsE (VarE "foo") (VarE "bar") [VarE "baz"] [])
+ , testCase "is not" $
+ test_parser exprUP "foo is not bar"
+ (NotE $ IsE (VarE "foo") (VarE "bar") [] [])
+ , testCase "single arg without parentheses" $
+ test_parser exprUP "foo is bar baz"
+ (IsE (VarE "foo") (VarE "bar") [VarE "baz"] [])
+ ]
+ , testGroup "Call and index"
+ [ testCase "call nullary" $
+ test_parser exprUP "foo()" (CallE (VarE "foo") [] [])
+ , testCase "call 1 positional arg" $
+ test_parser exprUP "foo(a)" (CallE (VarE "foo") [VarE "a"] [])
+ , testCase "call 2 positional args" $
+ test_parser exprUP "foo(a, b)" (CallE (VarE "foo") [VarE "a", VarE "b"] [])
+ , testCase "call 1 named arg" $
+ test_parser exprUP "foo(a=b)" (CallE (VarE "foo") [] [("a", VarE "b")])
+ , testCase "call 2 named args" $
+ test_parser exprUP "foo(a=b, c = d)" (CallE (VarE "foo") [] [("a", VarE "b"), ("c", VarE "d")])
+ , testCase "call mixed args" $
+ test_parser exprUP "foo(a, b = c)" (CallE (VarE "foo") [VarE "a"] [("b", VarE "c")])
+ , testCase "index" $
+ test_parser exprUP "foo[bar]" (IndexE (VarE "foo") (VarE "bar"))
+ , testCase "slice begin" $
+ test_parser exprUP "foo[bar:]" (SliceE (VarE "foo") (Just $ VarE "bar") Nothing)
+ , testCase "slice end" $
+ test_parser exprUP "foo[:bar]" (SliceE (VarE "foo") Nothing (Just $ VarE "bar"))
+ , testCase "slice both" $
+ test_parser exprUP "foo[bar:baz]" (SliceE (VarE "foo") (Just $ VarE "bar") (Just $ VarE "baz"))
+ , testCase "dot-member" $
+ test_parser exprUP "foo.bar" (DotE (VarE "foo") "bar")
+ , testCase "filter (no args)" $
+ test_parser exprUP "foo|bar" (FilterE (VarE "foo") (VarE "bar") [] [])
+ , testCase "filter (positional arg)" $
+ test_parser exprUP "foo|bar(baz)" (FilterE (VarE "foo") (VarE "bar") [VarE "baz"] [])
+ , testCase "filter (kw arg)" $
+ test_parser exprUP "foo|bar(baz=quux)" (FilterE (VarE "foo") (VarE "bar") [] [("baz", VarE "quux")])
+ ]
+ ]
+ , testGroup "Precedence"
+ [ testCase "+ vs *" $
+ test_parser exprUP
+ "a * b + c * d"
+ (PlusE
+ (MulE (VarE "a") (VarE "b"))
+ (MulE (VarE "c") (VarE "d"))
+ )
+ , testCase "* vs **" $
+ test_parser exprUP
+ "a ** b * c ** d"
+ (MulE
+ (PowerE (VarE "a") (VarE "b"))
+ (PowerE (VarE "c") (VarE "d"))
+ )
+ , testCase "+ vs ~" $
+ test_parser exprUP
+ "a + b ~ c + d"
+ (ConcatE
+ (PlusE (VarE "a") (VarE "b"))
+ (PlusE (VarE "c") (VarE "d"))
+ )
+ , testCase "== vs and" $
+ test_parser exprUP
+ "a == b and c == d"
+ (AndE
+ (EqualE (VarE "a") (VarE "b"))
+ (EqualE (VarE "c") (VarE "d"))
+ )
+ , testCase "+ vs ." $
+ test_parser exprUP
+ "a + b[c]"
+ (PlusE
+ (VarE "a")
+ (IndexE
+ (VarE "b")
+ (VarE "c")
+ )
+ )
+ , testCase "is vs ==" $
+ test_parser exprUP
+ "a is b == c"
+ (EqualE
+ (IsE (VarE "a") (VarE "b") [] [])
+ (VarE "c")
+ )
+ , testCase "is vs and" $
+ test_parser exprUP
+ "a is b and c is d"
+ (AndE
+ (IsE (VarE "a") (VarE "b") [] [])
+ (IsE (VarE "c") (VarE "d") [] [])
+ )
+ , testCase "multiple filters" $
+ test_parser exprUP
+ "a|b|c"
+ (FilterE
+ (FilterE (VarE "a") (VarE "b") [] [])
+ (VarE "c")
+ [] []
+ )
+ ]
+ , testGroup "Statement"
+ [ testProperty "roundTrip" (prop_parserRoundTrip statementUP simplifyS)
+ , testGroup "ImmediateS"
+ [ testCase "plain immediate" $
+ test_parser statementUP
+ "Hello, world!"
+ (ImmediateS $ Encoded "Hello, world!")
+ , testCase "immediate with curly braces" $
+ test_parser statementUP
+ "Hello, {world}!"
+ (ImmediateS $ Encoded "Hello, {world}!")
+ ]
+ , testGroup "InterpolationS"
+ [ testCase "interpolation" $
+ test_parser statementUP
+ "{{ world }}"
+ (InterpolationS (VarE "world"))
+ , testCase "dict interpolation" $
+ test_parser statementUP
+ "{{ {\"bar\": { \"foo\": world }} }}"
+ (InterpolationS (DictE [(StringLitE "bar", (DictE [(StringLitE "foo", VarE "world")]))]))
+ ]
+ , testCase "CommentS" $
+ test_parser statementUP
+ "{# world #}"
+ (CommentS "world")
+ , testGroup "IfS"
+ [ testCase "if" $
+ test_parser statementUP
+ "{% if foo %}blah{% endif %}"
+ (IfS (VarE "foo") (ImmediateS $ Encoded "blah") Nothing)
+ , testCase "if-else" $
+ test_parser statementUP
+ "{% if foo %}blah{% else %}pizza{% endif %}"
+ (IfS (VarE "foo") (ImmediateS $ Encoded "blah") (Just (ImmediateS $ Encoded "pizza")))
+ ]
+ , testGroup "SetS, SetBlockS"
+ [ testCase "set" $
+ test_parser statementUP
+ "{% set foo = bar %}"
+ (SetS (SetVar "foo") (VarE "bar"))
+ , testCase "set block" $
+ test_parser statementUP
+ "{% set foo %}foo{% endset %}"
+ (SetBlockS (SetVar "foo") (ImmediateS $ Encoded "foo") Nothing)
+ , testCase "set block with filter" $
+ test_parser statementUP
+ "{% set foo | bar %}foo{% endset %}"
+ (SetBlockS (SetVar "foo") (ImmediateS $ Encoded "foo") (Just (VarE "bar")))
+ ]
+ , testGroup "ForS"
+ [ testCase "for" $
+ test_parser statementUP
+ "{% for user in users %}{{ user.name }}{% endfor %}"
+ (ForS
+ Nothing (Identifier "user") (VarE "users")
+ Nothing
+ NotRecursive
+ (InterpolationS (DotE (VarE "user") "name"))
+ Nothing
+ )
+ , testCase "for-else" $
+ test_parser statementUP
+ "{% for user in users %}{{ user.name }}{% else %}Nope{% endfor %}"
+ (ForS
+ Nothing (Identifier "user") (VarE "users")
+ Nothing
+ NotRecursive
+ (InterpolationS (DotE (VarE "user") "name"))
+ (Just (ImmediateS (Encoded "Nope")))
+ )
+ , testCase "for-if" $
+ test_parser statementUP
+ "{% for user in users if user.name is defined %}{{ user.name }}{% endfor %}"
+ (ForS
+ Nothing (Identifier "user") (VarE "users")
+ (Just (IsE (DotE (VarE "user") "name") (VarE "defined") [] []))
+ NotRecursive
+ (InterpolationS (DotE (VarE "user") "name"))
+ Nothing
+ )
+ , testCase "for-if-else" $
+ test_parser statementUP
+ "{% for user in foo if not bar else baz %}{{ user.name }}{% endfor %}"
+ (ForS
+ Nothing (Identifier "user")
+ (TernaryE (NotE (VarE "bar")) (VarE "foo") (VarE "baz"))
+ Nothing
+ NotRecursive
+ (InterpolationS (DotE (VarE "user") "name"))
+ Nothing
+ )
+ , testCase "for-if-recursive" $
+ test_parser statementUP
+ "{% for user in foo if bar recursive %}{{ user.name }}{% endfor %}"
+ (ForS
+ Nothing (Identifier "user")
+ (VarE "foo")
+ (Just (VarE "bar"))
+ Recursive
+ (InterpolationS (DotE (VarE "user") "name"))
+ Nothing
+ )
+ ]
+ , testGroup "IncludeS"
+ [ testCase "include" $
+ test_parser statementUP
+ "{% include \"foo\" %}"
+ (IncludeS (StringLitE "foo") RequireMissing WithContext)
+ , testCase "include without context" $
+ test_parser statementUP
+ "{% include \"foo\" without context %}"
+ (IncludeS (StringLitE "foo") RequireMissing WithoutContext)
+ , testCase "include ignore missing" $
+ test_parser statementUP
+ "{% include \"foo\" ignore missing %}"
+ (IncludeS (StringLitE "foo") IgnoreMissing WithContext)
+ , testCase "include ignore missing without context" $
+ test_parser statementUP
+ "{% include \"foo\" ignore missing without context %}"
+ (IncludeS (StringLitE "foo") IgnoreMissing WithoutContext)
+ ]
+ , testGroup "ImportS"
+ [ testCase "plain import" $
+ test_parser statementUP
+ "{% import 'foo.html' %}"
+ (ImportS (StringLitE "foo.html") Nothing Nothing RequireMissing WithoutContext)
+ , testCase "qualified import" $
+ test_parser statementUP
+ "{% import 'foo.html' as foo %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") Nothing RequireMissing WithoutContext)
+ , testCase "from import" $
+ test_parser statementUP
+ "{% from 'foo.html' import bar %}"
+ (ImportS (StringLitE "foo.html") Nothing (Just [("bar", Nothing)]) RequireMissing WithoutContext)
+ , testCase "from import qualified" $
+ test_parser statementUP
+ "{% from 'foo.html' as foo import bar %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") (Just [("bar", Nothing)]) RequireMissing WithoutContext)
+ , testCase "from import as" $
+ test_parser statementUP
+ "{% from 'foo.html' import bar as baz %}"
+ (ImportS (StringLitE "foo.html") Nothing (Just [("bar", Just "baz")]) RequireMissing WithoutContext)
+ , testCase "from import qualified as" $
+ test_parser statementUP
+ "{% from 'foo.html' as foo import bar as baz %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") (Just [("bar", Just "baz")]) RequireMissing WithoutContext)
+ , testCase "from import qualified as ignore missing" $
+ test_parser statementUP
+ "{% from 'foo.html' as foo import bar as baz ignore missing %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") (Just [("bar", Just "baz")]) IgnoreMissing WithoutContext)
+ , testCase "from import qualified as with context" $
+ test_parser statementUP
+ "{% from 'foo.html' as foo import bar as baz with context %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") (Just [("bar", Just "baz")]) RequireMissing WithContext)
+ , testCase "from import qualified as ignore missing with context" $
+ test_parser statementUP
+ "{% from 'foo.html' as foo import bar as baz ignore missing with context %}"
+ (ImportS (StringLitE "foo.html") (Just "foo") (Just [("bar", Just "baz")]) IgnoreMissing WithContext)
+ ]
+ , testGroup "BlockS"
+ [ testCase "block" $
+ test_parser statementUP
+ "{% block foo %}Hello{% endblock %}"
+ (BlockS "foo" $ Block (ImmediateS . Encoded $ "Hello") NotScoped Optional)
+ , testCase "block (repeat block name)" $
+ test_parser statementUP
+ "{% block foo %}Hello{% endblock foo %}"
+ (BlockS "foo" $ Block (ImmediateS . Encoded $ "Hello") NotScoped Optional)
+ , testCase "block (repeat wrong block name)" $
+ test_parserEx statementUP
+ "{% block foo %}Hello{% endblock bar %}"
+ (Left . unlines $
+ [ ":1:33:"
+ , " |"
+ , "1 | {% block foo %}Hello{% endblock bar %}"
+ , " | ^^"
+ , "unexpected \"ba\""
+ , "expecting \"%}\", \"foo\", '+', '-', or white space"
+ ])
+ ]
+ , testGroup "WithS"
+ [ testCase "plain" $
+ test_parser statementUP
+ "{% with %}hello{% endwith %}"
+ (WithS [] (ImmediateS . Encoded $ "hello"))
+ , testCase "one variable" $
+ test_parser statementUP
+ "{% with foo = bar %}hello{% endwith %}"
+ (WithS [("foo", VarE "bar")] (ImmediateS . Encoded $ "hello"))
+ , testCase "two variables" $
+ test_parser statementUP
+ "{% with foo = bar, baz = 123 %}hello{% endwith %}"
+ (WithS [("foo", VarE "bar"), ("baz", IntLitE 123)] (ImmediateS . Encoded $ "hello"))
+ ]
+ ]
+ , testGroup "Trimming"
+ [ testCase "trim newline" $
+ test_parser statementUP
+ "{% set foo = bar %}\nHello"
+ (GroupS [SetS (SetVar "foo") (VarE "bar"), ImmediateS . Encoded $ "Hello"])
+ , testCase "trim only newline" $
+ test_parser statementUP
+ "{% set foo = bar %}\n Hello"
+ (GroupS [SetS (SetVar "foo") (VarE "bar"), ImmediateS . Encoded $ " Hello"])
+ , testCase "keep newline" $
+ test_parser statementUP
+ "{% set foo = bar +%}\nHello"
+ (GroupS
+ [ SetS (SetVar "foo") (VarE "bar")
+ , ImmediateS . Encoded $ "\nHello"
+ ])
+ , testCase "force-trim newline" $
+ test_parser statementUP
+ "{% set foo = bar -%}\nHello"
+ (GroupS [SetS (SetVar "foo") (VarE "bar"), ImmediateS . Encoded $ "Hello"])
+ , testCase "keep leading" $
+ test_parser statementUP
+ " {% set foo = bar %}"
+ (GroupS [ImmediateS . Encoded $ " ", SetS (SetVar "foo") (VarE "bar")])
+ , testCase "force-keep leading" $
+ test_parser statementUP
+ " {%+ set foo = bar %}"
+ (GroupS [ImmediateS . Encoded $ " ", SetS (SetVar "foo") (VarE "bar")])
+ , testCase "trim leading" $
+ test_parser statementUP
+ " {%- set foo = bar %}"
+ (SetS (SetVar "foo") (VarE "bar"))
+ , testCase "trim both" $
+ test_parser statementUP
+ " {%- set foo = bar -%}\n"
+ (SetS (SetVar "foo") (VarE "bar"))
+ , testCase "trim leading after non-space" $
+ test_parser statementUP
+ "Hello,\n {%- set foo = bar %}"
+ (GroupS
+ [ ImmediateS . Encoded $ "Hello,\n"
+ , SetS (SetVar "foo") (VarE "bar")
+ ])
+ , testCase "trim trailing before non-space" $
+ test_parser statementUP
+ "{% set foo = bar -%} \nHello"
+ (GroupS [SetS (SetVar "foo") (VarE "bar"), ImmediateS . Encoded $ "Hello"])
+ , testCase "adjacent right and left trim" $
+ test_parser statementUP
+ "{% set foo = bar -%} \t \r\n\t {%- set baz = quux %}"
+ (GroupS [SetS (SetVar "foo") (VarE "bar"), SetS (SetVar "baz") (VarE "quux")])
+ ]
+ , testGroup "Regressions"
+ [ testCase "-%} after test" $
+ test_parser statementUP
+ "{%- for a in b if a -%}\na{%- endfor -%}"
+ ( ForS
+ Nothing
+ "a"
+ (VarE "b")
+ (Just (VarE "a"))
+ NotRecursive
+ (ImmediateS (Encoded "a"))
+ Nothing
+ )
+ ]
+ ]
+
+statementUP :: P Statement
+statementUP = simplifyS . unPositionedS <$> statement
+
+exprUP :: P Expr
+exprUP = unPositionedE <$> expr
+
+test_parser :: (Eq a, Show a) => P a -> Text -> a -> Assertion
+test_parser p input expected =
+ test_parserEx p input (Right expected)
+
+test_parserEx :: (Eq a, Show a) => P a -> Text -> (Either String a) -> Assertion
+test_parserEx p input expected = do
+ assertBool
+ ("expected:\n" ++ either id show expected ++ "\n" ++
+ "actual:\n" ++ either id show actual)
+ (expected == actual)
+ where
+ actual = parseGinger (p <* eof) "" input
+
+prop_parserRoundTrip :: (Eq a, Show a, Arbitrary a, RenderSyntax a) => P a -> (a -> a) -> a -> Property
+prop_parserRoundTrip p postProcess v =
+ let src = renderSyntaxText $ v
+ expected = Right . postProcess $ v
+ actual = either (Left . ImmediateString) (Right . postProcess) $
+ parseGinger (p <* eof) "" src
+ in
+ counterexample (Text.unpack src) $
+ expected === actual
+
+newtype ImmediateString = ImmediateString String
+ deriving (Eq)
+
+instance Show ImmediateString where
+ show (ImmediateString str) = str
diff --git a/test/Language/Ginger/TestUtils.hs b/test/Language/Ginger/TestUtils.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Ginger/TestUtils.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Language.Ginger.TestUtils
+where
+
+import Control.Monad.Identity
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Map.Strict as Map
+import Test.Tasty.QuickCheck
+
+import Language.Ginger.Interpret
+import Language.Ginger.Value
+import Language.Ginger.AST
+
+newtype ArbitraryText = ArbitraryText { unArbitraryText :: Text }
+ deriving (Eq, Ord)
+
+instance Show ArbitraryText where
+ show (ArbitraryText t) = show t
+
+instance Arbitrary ArbitraryText where
+ arbitrary = ArbitraryText . Text.pack <$> listOf arbitrary
+
+instance Monad m => ToValue ArbitraryText m where
+ toValue (ArbitraryText t) = toValue t
+
+newtype NonEmptyText = NonEmptyText Text
+ deriving (Eq, Ord)
+
+instance Show NonEmptyText where
+ show (NonEmptyText t) = show t
+
+instance Arbitrary NonEmptyText where
+ arbitrary = NonEmptyText . Text.pack <$> listOf1 arbitrary
+
+instance Monad m => ToValue NonEmptyText m where
+ toValue (NonEmptyText t) = toValue t
+
+newtype ArbitraryByteString = ArbitraryByteString ByteString
+ deriving (Eq, Ord)
+
+instance Show ArbitraryByteString where
+ show (ArbitraryByteString t) = show t
+
+instance Arbitrary ArbitraryByteString where
+ arbitrary = ArbitraryByteString . BS.pack <$> listOf arbitrary
+
+instance Monad m => ToValue ArbitraryByteString m where
+ toValue (ArbitraryByteString t) = toValue t
+
+newtype PositiveInt i = PositiveInt i
+ deriving (Eq, Ord)
+
+instance Show i => Show (PositiveInt i) where
+ show (PositiveInt t) = show t
+
+instance (Arbitrary i, Integral i) => Arbitrary (PositiveInt i) where
+ arbitrary = do
+ s <- getSize
+ PositiveInt . fromInteger <$> chooseInteger (1, fromIntegral $ max 1 s)
+ shrink (PositiveInt i) = map PositiveInt . filter (> 0) $ shrink i
+
+instance (Monad m, ToValue i m) => ToValue (PositiveInt i) m where
+ toValue (PositiveInt t) = toValue t
+
+safeAt :: Int -> [a] -> Maybe a
+safeAt n = listToMaybe . drop n
+
+justNonzero :: (Eq a, Num a) => a -> Maybe a
+justNonzero 0 = Nothing
+justNonzero n = Just n
+
+justPositive :: (Eq a, Ord a, Num a) => a -> Maybe a
+justPositive n | n > 0 = Just n
+justPositive _ = Nothing
+
+leftPRE :: RuntimeError -> Either PrettyRuntimeError a
+leftPRE = Left . PrettyRuntimeError
+
+mapLeft :: (a -> b) -> Either a c -> Either b c
+mapLeft f (Left x) = Left (f x)
+mapLeft _ (Right x) = Right x
+
+mapRight :: (b -> c) -> Either a b -> Either a c
+mapRight _ (Left x) = Left x
+mapRight f (Right x) = Right (f x)
+
+newtype PrettyRuntimeError = PrettyRuntimeError RuntimeError
+ deriving (Eq)
+
+instance Show PrettyRuntimeError where
+ show (PrettyRuntimeError (TemplateParseError _ err)) = Text.unpack err
+ show (PrettyRuntimeError e) = show e
+
+runGingerIdentity :: GingerT Identity a -> a
+runGingerIdentity action =
+ either (error . show) id $ runGingerIdentityEither action
+
+runGingerIdentityEither :: GingerT Identity a -> Either PrettyRuntimeError a
+runGingerIdentityEither action =
+ mapLeft (PrettyRuntimeError . unPositionedError) $
+ runIdentity (runGingerT action defContext defEnv)
+
+runGingerIdentityWithLoader :: TemplateLoader Identity
+ -> GingerT Identity a
+ -> a
+runGingerIdentityWithLoader loader action =
+ either (error . show) id $ runGingerIdentityEitherWithLoader loader action
+
+runGingerIdentityEitherWithLoader :: TemplateLoader Identity
+ -> GingerT Identity a
+ -> Either PrettyRuntimeError a
+runGingerIdentityEitherWithLoader loader action =
+ mapLeft (PrettyRuntimeError . unPositionedError) $
+ runIdentity (runGingerT action defContext { contextLoadTemplateFile = loader } defEnv)
+
+mockLoader :: [(Text, Text)] -> TemplateLoader Identity
+mockLoader entries name =
+ pure $ Map.lookup name tpls
+ where
+ tpls = Map.fromList entries
+
+unPositionedS :: Statement -> Statement
+unPositionedS = traverseS go unPositionedE
+ where
+ go (PositionedS _ s) = unPositionedS s
+ go s = s
+
+unPositionedE :: Expr -> Expr
+unPositionedE = traverseE go unPositionedS
+ where
+ go (PositionedE _ e) = unPositionedE e
+ go e = e
+
+unPositionedError :: RuntimeError -> RuntimeError
+unPositionedError (PositionedError _ e) = unPositionedError e
+unPositionedError e = e
diff --git a/test/Language/Ginger/Value/Tests.hs b/test/Language/Ginger/Value/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Ginger/Value/Tests.hs
@@ -0,0 +1,25 @@
+module Language.Ginger.Value.Tests
+where
+
+import Language.Ginger.Value
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import qualified Data.Text as Text
+import Data.String (IsString (..))
+
+tests :: TestTree
+tests = testGroup "Language.Ginger.Value"
+ [ testProperty "Int toScalar" prop_IntToScalar
+ , testProperty "Scalar IsString" prop_ScalarIsString
+ ]
+
+prop_IntToScalar :: Int -> Property
+prop_IntToScalar i =
+ IntScalar (fromIntegral i) === toScalar i
+
+
+prop_ScalarIsString :: String -> Property
+prop_ScalarIsString str =
+ let s1 = fromString str
+ s2 = StringScalar . Text.pack $ str
+ in s1 === s2
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,21 @@
+module Main
+where
+
+import Test.Tasty
+
+import qualified Language.Ginger.Value.Tests as Value
+import qualified Language.Ginger.AST.Tests as AST
+import qualified Language.Ginger.Interpret.Tests as Interpret
+import qualified Language.Ginger.Parse.Tests as Parse
+
+tests :: TestTree
+tests =
+ testGroup "ginger"
+ [ Value.tests
+ , AST.tests
+ , Interpret.tests
+ , Parse.tests
+ ]
+
+main :: IO ()
+main = defaultMain tests