diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -20,3 +20,14 @@ like in Jinja. - Added an RNG state to the execution environment; this is necessary in order to support the random() function. + +2.1.0.1 + +- Fix build errors on GHC 9.2 through 9.10 + +2.2.0.0 + +- Added built-ins: + - groupby() +- Added printf-style % string formatting +- Fixed some spurious test failures diff --git a/ginger2.cabal b/ginger2.cabal --- a/ginger2.cabal +++ b/ginger2.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ginger2 -version: 2.1.0.1 +version: 2.2.0.0 synopsis: Jinja templates for Haskell description: Ginger2 approximates Jinja2 (https://jinja.palletsprojects.com/) in Haskell. @@ -39,6 +39,7 @@ , Language.Ginger.Render , Language.Ginger.RuntimeError , Language.Ginger.SourcePosition + , Language.Ginger.StringFormatting -- other-modules: -- other-extensions: build-depends: base >=4.14.0.0 && <5 diff --git a/src/Language/Ginger/BuiltinsAutodoc.hs b/src/Language/Ginger/BuiltinsAutodoc.hs --- a/src/Language/Ginger/BuiltinsAutodoc.hs +++ b/src/Language/Ginger/BuiltinsAutodoc.hs @@ -34,8 +34,8 @@ markdownToHaddock = Text.replace "'" "\\'" . Text.replace "\"" "\\\"" . - Text.replace "\n" "\n\n" . - Text.replace "`" "@" + Text.replace "`" "@" . + Text.replace "```" "@" addHaddockFromFile :: FilePath -> DecsQ addHaddockFromFile path = do @@ -117,16 +117,11 @@ pure [] where goTy :: TypeDoc -> Text - goTy TypeDocAny = "@any@" - goTy TypeDocNone = "@none@" - goTy (TypeDocSingle t) = "@" <> t <> "@" + goTy TypeDocAny = "any" + goTy TypeDocNone = "none" + goTy (TypeDocSingle t) = t goTy (TypeDocAlternatives ts) = - case Vector.unsnoc ts of - Just (ts', t) -> - "@" <> Text.intercalate "@, @" (Vector.toList $ ts') <> "@" <> - ", or @" <> t <> "@" - Nothing -> - "@" <> Text.intercalate "@ or @" (Vector.toList $ ts) <> "@" + "[" <> Text.intercalate " | " (Vector.toList $ ts) <> "]" goItemHeading :: Maybe Text -> Text -> Text -> [Text] goItemHeading namespaceMay prefix name = @@ -136,47 +131,48 @@ , "=== " <> maybe "" (<> ".") namespaceMay <> name ] + goArgSig :: ArgumentDoc -> Text + goArgSig arg = + argumentDocName arg <> + maybe "" ("=" <>) (argumentDocDefault arg) <> + maybe "" ((" : " <>) . goTy) (argumentDocType arg) + goArgDesc :: ArgumentDoc -> [Text] + goArgDesc arg = + [ "[@" <> argumentDocName arg <> "@]:" <> argumentDocDescription arg ] + goDocumentedItem :: Maybe Text -> Text -> (Identifier, ProcedureDoc) -> String goDocumentedItem namespaceMay prefix (name, d) = let qualifiedName = maybe "" (<> ".") namespaceMay <> identifierName name in Text.unpack . Text.unlines $ - goItemHeading namespaceMay prefix (identifierName name <> "()") ++ + goItemHeading namespaceMay prefix + (identifierName name) + ++ + [ "" + , "@" <> identifierName name + <> "(" <> (Text.intercalate ", " . map goArgSig . Vector.toList $ procedureDocArgs d) <> ")" + <> maybe "" ((" → " <>) . goTy) (procedureDocReturnType d) + <> "@" + , "" + ] + ++ ( if qualifiedName /= procedureDocName d && identifierName name /= procedureDocName d then [ "Alias for [" <> procedureDocName d <> "](#" <> prefix <> procedureDocName d <> ")" ] else - [ "" - , "__Arguments:__" - ] ++ ( if Vector.null (procedureDocArgs d) then - [ "none" - , "" - ] + [ ] else - [ "" ] ++ - [ "* @" <> argumentDocName arg - <> case argumentDocDefault arg of - Nothing -> "" - Just defval -> "=" <> defval - <> "@" - <> maybe "" ((" : " <>) . goTy) (argumentDocType arg) - <> case argumentDocDefault arg of - Nothing -> " __(required)__" - Just _ -> "" - <> (if argumentDocDescription arg /= "" then - " - " <> markdownToHaddock (argumentDocDescription arg) - else - "" - ) - | arg <- Vector.toList (procedureDocArgs d) - ] + [ "" + , "==== Arguments" + , "" + ] ++ + (concatMap goArgDesc . Vector.toList $ procedureDocArgs d) ++ + [ "" ] ) ++ [ "" - , "__Return type:__ " <> maybe "n/a" goTy (procedureDocReturnType d) - , "" , markdownToHaddock $ procedureDocDescription d ] ) @@ -197,6 +193,8 @@ goItem namespaceMay prefix (name, ProcedureV (NativeProcedure _ (Just d) _)) = goDocumentedItem namespaceMay prefix (name, d) + goItem namespaceMay prefix (name, ProcedureV NamespaceProcedure) = + goDocumentedItem namespaceMay prefix (name, namespaceProcedureDoc) goItem namespaceMay prefix (name, FilterV (NativeFilter (Just d) _)) = goDocumentedItem namespaceMay prefix (name, d) goItem namespaceMay prefix (name, TestV (NativeTest (Just d) _)) = diff --git a/src/Language/Ginger/Interpret/Builtins.hs b/src/Language/Ginger/Interpret/Builtins.hs --- a/src/Language/Ginger/Interpret/Builtins.hs +++ b/src/Language/Ginger/Interpret/Builtins.hs @@ -18,6 +18,7 @@ import Language.Ginger.RuntimeError import Language.Ginger.Value +import Control.Applicative ( (<|>) ) import Control.Monad.Except import Control.Monad.Trans (lift) import qualified Data.Aeson as JSON @@ -155,7 +156,7 @@ , ("float", ProcedureV fnToFloat) -- , ("forceescape", undefined) -- , ("format", undefined) - -- , ("groupby", undefined) + , ("groupby", ProcedureV fnGroupBy) -- , ("indent", undefined) , ("int", ProcedureV fnToInt) , ("items", ProcedureV fnItems) @@ -1893,6 +1894,77 @@ unit | otherwise = go multiplier units (value `div` multiplier) + +fnGroupBy :: forall m. Monad m => Procedure m +fnGroupBy = mkFn4 "groupby" + (Text.unlines + [ "Group a list of objects by an attribute." + , "The attribute can use dot notation for nested access, " <> + "e.g. `'address.city'`." + ] + ) + ( "value" + , Nothing :: Maybe [Value m] + , Just $ TypeDocAny + , "" + ) + ( "attribute" + , Nothing + , Just $ TypeDocAlternatives [ "string", "int" ] + , "Attribute to group by." + ) + ( "default" + , Just Nothing + , Just $ TypeDocAny + , "Default value to use if an object doesn't have the " <> + "requested attribute." + ) + ( "case_sensitive" + , Just True + , Just $ TypeDocSingle "bool" + , "Use case-sensitive comparisons for grouping objects." + ) + (Just $ TypeDocSingle "dict") + $ \value attrib (defValMay :: Maybe (Value m)) caseSensitive -> do + let getAttribPath :: Value m -> [Text] -> ExceptT RuntimeError m (Maybe (Value m)) + getAttribPath o [] = pure $ Just o + getAttribPath o (p:ps) = do + o'May <- eitherExceptM $ getAttrOrItemRaw o (Identifier p) + case o'May of + Just o' -> getAttribPath o' ps + Nothing -> pure $ Nothing + + let attribProjection :: Value m -> ExceptT RuntimeError m (Maybe (Value m)) + attribProjection = fmap (maybe (Just NoneV) Just) . case attrib of + Left i -> \obj -> + lift $ getItemRaw obj (IntV i) + Right t -> \obj -> + getAttribPath obj $ Text.splitOn "." t + + attribCaseFold :: Scalar -> Scalar + attribCaseFold (StringScalar t) = + if caseSensitive then + StringScalar t + else + StringScalar (Text.toCaseFold t) + attribCaseFold x = x + + append :: Map Scalar [Value m] -> Maybe (Scalar, Value m) -> Map Scalar [Value m] + append m Nothing = m + append m (Just (k, v)) = + Map.insertWith (flip (++)) k [v] m + + prepare :: Value m -> ExceptT RuntimeError m (Maybe (Scalar, Value m)) + prepare v = do + kMay <- attribProjection v + skMay <- mapM + (fmap attribCaseFold . eitherExcept . asScalarVal) + (kMay <|> defValMay) + case skMay of + Nothing -> pure Nothing + Just k -> pure $ Just (k, v) + + foldl' append mempty <$> mapM prepare value fnBatch :: forall m. Monad m => Procedure m fnBatch = mkFn3 "batch" diff --git a/src/Language/Ginger/Interpret/Eval.hs b/src/Language/Ginger/Interpret/Eval.hs --- a/src/Language/Ginger/Interpret/Eval.hs +++ b/src/Language/Ginger/Interpret/Eval.hs @@ -39,6 +39,7 @@ import qualified Language.Ginger.Parse as Parse import Language.Ginger.RuntimeError import Language.Ginger.SourcePosition +import Language.Ginger.StringFormatting import Language.Ginger.Value import Control.Monad (foldM, forM, void) @@ -398,7 +399,6 @@ -> GingerT m (Value m) boolBinop f a b = native . pure $ boolFunc2 f a b - valuesEqual :: Monad m => Value m -> Value m @@ -436,6 +436,12 @@ ordering <- compareValues a b pure $ BoolV (f ordering) +printfValues :: Monad m => Text -> Value m -> GingerT m (Value m) +printfValues fmtText (ListV args) = do + pure . StringV . Text.pack $ printfList (Text.unpack fmtText) (V.toList args) +printfValues fmtText x = do + pure . StringV . Text.pack $ printfList (Text.unpack fmtText) [x] + dictsEqual :: forall m. Monad m => Map Scalar (Value m) -> Map Scalar (Value m) @@ -457,6 +463,7 @@ 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 (StringV a) b = printfValues 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 diff --git a/src/Language/Ginger/StringFormatting.hs b/src/Language/Ginger/StringFormatting.hs new file mode 100644 --- /dev/null +++ b/src/Language/Ginger/StringFormatting.hs @@ -0,0 +1,83 @@ +module Language.Ginger.StringFormatting +where + +import Control.Applicative ( (<|>) ) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import Text.Printf (printf, PrintfArg) +import Data.Maybe (fromMaybe) +import Data.Void (Void) +import Data.Char (isDigit) + +printfList :: PrintfArg a => String -> [a] -> String +printfList fmt args = + leader ++ concat (zipWith printf fmts args) + where + (leader, fmts) = splitPrintfFormat fmt + +splitPrintfFormat :: String -> (String, [String]) +splitPrintfFormat fmt = + fromMaybe ("", []) $ P.parseMaybe pPrintfFormats fmt + +type P a = P.Parsec Void String a + +pPrintfFormats :: P (String, [String]) +pPrintfFormats = (,) <$> pLeader <*> P.many pPrintfFormat + +pLeader :: P String +pLeader = concat <$> P.many (("%" <$ pDoublePercent) <|> pPrintfPlainChars) + +pTrailer :: P String +pTrailer = concat <$> P.many (pDoublePercent <|> pPrintfPlainChars) + +pDoublePercent :: P String +pDoublePercent = P.chunk "%%" + +pPrintfPlainChars :: P String +pPrintfPlainChars = P.takeWhile1P (Just "plain characters") (/= '%') + +pPrintfFormat :: P String +pPrintfFormat = do + leadingPercent <- P.chunk "%" + flags <- P.takeWhileP (Just "flags") (`elem` flagChars) + fieldWidth <- pFieldWidth + precision <- P.option "" $ (P.chunk "." *> pFieldWidth) + widthModifier <- P.takeWhileP (Just "width modifier") (`elem` widthChars) + formatChar <- P.choice + [ 'd' <$ P.char 'i' + , 'v' <$ P.satisfy (`elem` stringFormatChars) + , P.satisfy (`elem` formatChars) + , pure 'v' + ] + remaining <- pTrailer + pure $ concat + [ leadingPercent + , flags + , fieldWidth + , precision + , widthModifier + , [formatChar] + , remaining + ] + + where + pFieldWidth :: P String + pFieldWidth = P.chunk "*" <|> pNumericFieldWidth + + pNumericFieldWidth :: P String + pNumericFieldWidth = + (++) <$> P.option "" (P.chunk "-") + <*> P.takeWhileP (Just "numeric field width") isDigit + + flagChars :: [Char] + flagChars = " +-0#" + + widthChars :: [Char] + widthChars = "lLhH" + + stringFormatChars :: [Char] + stringFormatChars = "rsa" + + formatChars :: [Char] + formatChars = "cdobuxXfFgGeEsv" + diff --git a/src/Language/Ginger/Value.hs b/src/Language/Ginger/Value.hs --- a/src/Language/Ginger/Value.hs +++ b/src/Language/Ginger/Value.hs @@ -46,6 +46,7 @@ import System.Random (RandomGen (..), SplitGen (..)) import Test.Tasty.QuickCheck (Arbitrary (..)) import qualified Test.Tasty.QuickCheck as QC +import Text.Printf (PrintfArg (..)) import Text.Read (readMaybe) import Language.Ginger.AST @@ -192,6 +193,33 @@ | MutableRefV !RefID deriving (Ord) +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) + instance FromJSON (Value m) where parseJSON v@JSON.Object {} = DictV <$> parseJSON v parseJSON v@JSON.Array {} = ListV <$> parseJSON v @@ -203,13 +231,6 @@ 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 @@ -241,6 +262,21 @@ DictV a == DictV b = a == b _ == _ = False +instance PrintfArg (Value m) where + formatArg (BoolV b) = formatArg (fromEnum b) + formatArg (IntV i) = formatArg i + formatArg (FloatV f) = formatArg f + formatArg (StringV t) = formatArg t + formatArg (EncodedV (Encoded t)) = formatArg t + formatArg ScalarV {} = formatArg ("" :: String) + formatArg (ListV xs) = \fmt x -> foldr (flip formatArg fmt) x xs + formatArg (DictV xs) = formatArg . ListV . V.fromList . Map.elems $ xs + formatArg (NativeV {}) = formatArg ("[[object]]" :: String) + formatArg (ProcedureV {}) = formatArg ("[[procedure]]" :: String) + formatArg (FilterV {}) = formatArg ("[[filter]]" :: String) + formatArg (TestV {}) = formatArg ("[[test]]" :: String) + formatArg (MutableRefV {}) = formatArg ("[[ref]]" :: String) + tagNameOf :: Value m -> Text tagNameOf ScalarV {} = "scalar" tagNameOf ListV {} = "list" @@ -251,32 +287,12 @@ 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) +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 newtype ObjectID = ObjectID { unObjectID :: Text } deriving (Eq, Ord) @@ -348,6 +364,33 @@ ) | GingerProcedure !(Env m) ![(Identifier, Maybe (Value m))] !Expr | NamespaceProcedure + +namespaceProcedureDoc :: ProcedureDoc +namespaceProcedureDoc = + ProcedureDoc + { procedureDocName = "namespace" + , procedureDocArgs = mempty + , procedureDocReturnType = Just $ TypeDocSingle "namespace" + , procedureDocDescription = Text.unlines + [ "Create a namespace object." + , "Namespace objects are mutable dictionary-like objects; the main " <> + "use case for these is to work around the fact that `{% for %}` " <> + "loops, macros, and other constructs establish local scopes, " <> + "which means that any `{% set %}` invocations inside those will " <> + "not propagate to the containing scope." + , "" + , "Using a namespace object, this problem can be solved like in this example:" + , "" + , "```" + , "{% set ns = namespace() %}" + , "{% for x in items %}" + , " {{ x.bar }}" + , " {% set ns.foo = x.foo %}" + , "{% endfor %}" + , "{{ ns.foo }}" + , "```" + ] + } instance Ord (Procedure m) where compare NamespaceProcedure NamespaceProcedure = EQ diff --git a/test/Language/Ginger/Interpret/Tests.hs b/test/Language/Ginger/Interpret/Tests.hs --- a/test/Language/Ginger/Interpret/Tests.hs +++ b/test/Language/Ginger/Interpret/Tests.hs @@ -32,10 +32,11 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Word (Word8, Word16, Word32, Word64) +import System.Random (mkStdGen, splitGen, uniformR) import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.QuickCheck hiding ((.&.)) -import System.Random (mkStdGen, splitGen, uniformR) +import Text.Printf (printf) import Language.Ginger.AST import Language.Ginger.Interpret @@ -107,6 +108,34 @@ , testProperty "Integer modulo" (prop_binopCond @Integer Just justNonzero BinopMod mod) , testProperty "Integer power" (prop_binopCond @Integer @Integer justPositive justPositive BinopPower (^)) + , testGroup "Printf formatting operator" + [ testProperty "single integer arg, %i" + (prop_binop @Text @Integer @Text BinopMod + (\fmt val -> Text.pack $ printf (Text.unpack fmt) val) + "%i" + ) + , testProperty "single string arg, %s" + (prop_binop @Text @Text @Text BinopMod + (\fmt val -> Text.pack $ printf (Text.unpack fmt) val) + "%s" + ) + , testProperty "int + string args, %d %s" + (prop_binop @Text @(Integer, Text) @Text BinopMod + (\fmt (i, s) -> Text.pack $ printf (Text.unpack fmt) i s) + "%d %s" + ) + , testProperty "single string arg, a%s" + (prop_binop @Text @Text @Text BinopMod + (\fmt val -> Text.pack $ printf (Text.unpack fmt) val) + "a%s" + ) + , testProperty "single string arg, %%%s" + (prop_binop @Text @Text @Text BinopMod + (\fmt val -> Text.pack $ printf (Text.unpack fmt) val) + "%%%s" + ) + ] + , testProperty "Double addition" (prop_binop @Double BinopPlus (+)) , testProperty "Double subtraction" (prop_binop @Double BinopMinus (-)) , testProperty "Double multiplication" (prop_binop @Double BinopMul (*)) @@ -694,6 +723,46 @@ 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 "groupby" $ + prop_eval + (\(Identifier a, Identifier b, itemsA, itemsB) -> + FilterE + (ListE $ + V.fromList + [ DictE + [ (StringLitE "foo", StringLitE a) + , (StringLitE "bar", IntLitE val) + ] + | val <- itemsA + ] + <> + V.fromList + [ DictE + [ (StringLitE "foo", StringLitE b) + , (StringLitE "bar", IntLitE val) + ] + | val <- itemsB + ] + ) + (VarE "groupby") + [StringLitE "foo"] + []) + (\(Identifier a, Identifier b, itemsA, itemsB) -> + DictV $ + Map.fromList $ + ( if null itemsA then + [] + else + [ (StringScalar a, ListV $ V.fromList [ DictV $ Map.fromList [ ("foo", StringV a), ("bar", IntV val) ] | val <- itemsA ] ) + ] + ) ++ + ( if null itemsB then + [] + else + [ (StringScalar b, ListV $ V.fromList [ DictV $ Map.fromList [ ("foo", StringV b), ("bar", IntV val) ] | val <- itemsB ] ) + ] + ) + ) , testProperty "batch with fill" $ prop_eval (\(PositiveInt i, PositiveInt j, PositiveInt x, f) -> @@ -849,32 +918,36 @@ (\(NonEmptyText needle, _) -> [StringLitE needle]) (\_ -> TrueV) , testProperty "string split (no sep)" $ - prop_method "split" + prop_methodCond "split" + (\(NonEmptyText sep, NonEmptyText item) -> + not (sep `Text.isInfixOf` item) + ) (\(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 + (\(NonEmptyText _sep, NonEmptyText item) -> ListV $ V.singleton (StringV item) ) , testProperty "string split" $ - prop_method "split" + prop_methodCond "split" + (\(NonEmptyText sep, NonEmptyText item, PositiveInt _i) -> + not + ( sep `Text.isInfixOf` item + || Text.take 1 sep `Text.isSuffixOf` item + || Text.takeEnd 1 sep `Text.isPrefixOf` item + ) + ) (\(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) + (\(NonEmptyText _sep, NonEmptyText item, PositiveInt i) -> + ListV $ V.replicate (i + 1) (StringV item) ) , testProperty "string splitlines" $ prop_method "splitlines" @@ -1393,6 +1466,8 @@ resultG = runGingerIdentityEither 0 (setVar name1 (toValue val1) >> eval expr) in name1 /= name2 ==> + varOK name1 ==> + varOK name2 ==> resultG === leftPRE (NotInScopeError (identifierName name2)) prop_nativeNullary :: Identifier -> Integer -> Property @@ -1485,11 +1560,11 @@ in result === BoolV expected -prop_eval :: (Arbitrary a, Show a, Show e, Eval Identity e) => (a -> e) -> (a -> Value Identity) -> a -> Property +prop_eval :: (Arbitrary a, Show a, RenderSyntax e, Eval Identity e) => (a -> e) -> (a -> Value Identity) -> a -> Property prop_eval mkEvaluable mkExpected = prop_evalRNG mkEvaluable (const mkExpected) 0 -prop_evalRNG :: (Arbitrary a, Show a, Show e, Eval Identity e) +prop_evalRNG :: (Arbitrary a, Show a, RenderSyntax e, Eval Identity e) => (a -> e) -> (Int -> a -> Value Identity) -> Int @@ -1500,7 +1575,7 @@ expected = mkExpected seed x result = runGingerIdentity seed $ eval e in - counterexample (show e) $ + counterexample (Text.unpack $ renderSyntaxText e) $ result === expected prop_attr :: (Arbitrary a, Show a, ToValue b Identity) @@ -1520,8 +1595,19 @@ -> (a -> Value Identity) -> a -> Property -prop_method methodName mkSelf mkArgs mkExpected t = +prop_method methodName = prop_methodCond methodName (const True) + +prop_methodCond :: (Arbitrary a, Show a) + => Identifier + -> (a -> Bool) + -> (a -> Expr) + -> (a -> [Expr]) + -> (a -> Value Identity) + -> a + -> Property +prop_methodCond methodName valid mkSelf mkArgs mkExpected t = counterexample (show $ mkArgs t) $ + valid t ==> prop_eval (\t' -> CallE (DotE (mkSelf t) methodName) (mkArgs t') []) mkExpected t