ginger2 (empty) → 2.0.0.0
raw patch · 24 files changed
+11316/−0 lines, 24 filesdep +SHAdep +aesondep +array
Dependencies added: SHA, aeson, array, base, base64-bytestring, bytestring, cmark, containers, directory, filepath, ginger2, megaparsec, mtl, optparse-applicative, quickcheck-instances, regex-tdfa, scientific, tasty, tasty-hunit, tasty-quickcheck, text, time, vector, yaml
Files
- CHANGELOG +3/−0
- LICENSE +20/−0
- README.markdown +180/−0
- cli/Main.hs +239/−0
- ginger2.cabal +106/−0
- src/Language/Ginger.hs +123/−0
- src/Language/Ginger/AST.hs +693/−0
- src/Language/Ginger/FileLoader.hs +28/−0
- src/Language/Ginger/Interpret.hs +36/−0
- src/Language/Ginger/Interpret/Builtins.hs +2612/−0
- src/Language/Ginger/Interpret/DefEnv.hs +591/−0
- src/Language/Ginger/Interpret/Eval.hs +901/−0
- src/Language/Ginger/Interpret/Type.hs +322/−0
- src/Language/Ginger/Parse.hs +816/−0
- src/Language/Ginger/Render.hs +347/−0
- src/Language/Ginger/RuntimeError.hs +76/−0
- src/Language/Ginger/SourcePosition.hs +17/−0
- src/Language/Ginger/Value.hs +1244/−0
- test/Language/Ginger/AST/Tests.hs +14/−0
- test/Language/Ginger/Interpret/Tests.hs +2191/−0
- test/Language/Ginger/Parse/Tests.hs +569/−0
- test/Language/Ginger/TestUtils.hs +142/−0
- test/Language/Ginger/Value/Tests.hs +25/−0
- test/Main.hs +21/−0
+ CHANGELOG view
@@ -0,0 +1,3 @@+2.0.0.0++- Initial release
+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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++ <!DOCTYPE html>+ <html>+ <head>+ <title>{{ title }}</title>+ </head>+ {# This is a comment. Comments are removed from the output. #}+ <body>+ <menu id="nav-main">+ {% for item in navigation %}+ <li><a href="{{ item.url }}">{{ item.label }}</a></li>+ {% endfor %}+ </menu>+ <div class="layout-content-main">+ <h1>{{ title }}</h1>+ {{ body }}+ </div>+ </body>+ </html>++There are 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.
+ cli/Main.hs view
@@ -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])+ )+ ]
+ ginger2.cabal view
@@ -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
+ src/Language/Ginger.hs view
@@ -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
+ src/Language/Ginger/AST.hs view
@@ -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
+ src/Language/Ginger/FileLoader.hs view
@@ -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
+ src/Language/Ginger/Interpret.hs view
@@ -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
+ src/Language/Ginger/Interpret/Builtins.hs view
@@ -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)
+ src/Language/Ginger/Interpret/DefEnv.hs view
@@ -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
+ src/Language/Ginger/Interpret/Eval.hs view
@@ -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<any>")+ 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
+ src/Language/Ginger/Interpret/Type.hs view
@@ -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+
+ src/Language/Ginger/Parse.hs view
@@ -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)
+ src/Language/Ginger/Render.hs view
@@ -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 "<<native>>"+valueToExpr (ProcedureV _) = StringLitE "<<procedure>>"+valueToExpr (TestV _) = StringLitE "<<test>>"+valueToExpr (FilterV _) = StringLitE "<<filter>>"+valueToExpr (MutableRefV (RefID i)) = StringLitE $ "<<ref" <> 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
+ src/Language/Ginger/RuntimeError.hs view
@@ -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)+
+ src/Language/Ginger/SourcePosition.hs view
@@ -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)
+ src/Language/Ginger/Value.hs view
@@ -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 {}) = "<<native>>"+ show (ProcedureV {}) = "<<procedure>>"+ show (TestV {}) = "<<test>>"+ show (FilterV {}) = "<<filter>>"+ 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+ "<native function>"+ "<positional argument>"+ "value"+ "end of arguments"+ [(_, x)] ->+ f x+ (_:(name, x):_) ->+ pure . Left $+ ArgumentError+ "<native function>"+ (maybe "<positional argument>" 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+ "<native function>"+ "<positional argument>"+ "value"+ "end of arguments"+ [(_, x)] ->+ pure $ f x+ (_:(name, x):_) ->+ pure . Left $+ ArgumentError+ "<native function>"+ (maybe "<positional argument>" 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+ "<native function>"+ "<positional argument>"+ "value"+ "end of arguments"+ [_] ->+ pure . Left $+ ArgumentError+ "<native function>"+ "<positional argument>"+ "value"+ "end of arguments"+ [(_, x), (_, y)] ->+ pure $ f x y+ (_:_:(name, x):_) ->+ pure . Left $+ ArgumentError+ "<native function>"+ (maybe "<positional argument>" 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 "<native object>"+ , 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 "<native function>" "<positional argument>" "end of arguments" "value"++instance Applicative m => ToNativeProcedure m (m (Value m)) where+ toNativeProcedure action [] _ =+ Right <$> action+ toNativeProcedure _ _ _ =+ pure . Left $+ ArgumentError "<native function>" "<positional argument>" "end of arguments" "value"++instance Applicative m => ToNativeProcedure m (m (Either RuntimeError (Value m))) where+ toNativeProcedure action [] _ =+ action+ toNativeProcedure _ _ _ =+ pure . Left $+ ArgumentError "<native function>" "<positional argument>" "end of arguments" "value"++instance (Applicative m, ToNativeProcedure m a) => ToNativeProcedure m (Value m -> a) where+ toNativeProcedure _ [] _ =+ pure . Left $+ ArgumentError "<native function>" "<positional argument>" "value" "end of arguments"+ toNativeProcedure _ ((Just _, _):_) _ =+ pure . Left $+ ArgumentError "<native function>" "<positional argument>" "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 "<unknown>" "not a number"+leftNaN c | isInfinite c = Left $ NumericError "<unknown>" "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 "<unknown>" "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+ }
+ test/Language/Ginger/AST/Tests.hs view
@@ -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"+ [+ ]+
+ test/Language/Ginger/Interpret/Tests.hs view
@@ -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
+ test/Language/Ginger/Parse/Tests.hs view
@@ -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 $+ [ "<input>: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>" 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) "<input>" src+ in+ counterexample (Text.unpack src) $+ expected === actual++newtype ImmediateString = ImmediateString String+ deriving (Eq)++instance Show ImmediateString where+ show (ImmediateString str) = str
+ test/Language/Ginger/TestUtils.hs view
@@ -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
+ test/Language/Ginger/Value/Tests.hs view
@@ -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
+ test/Main.hs view
@@ -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