diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino -version: 0.0.0.16 +version: 0.0.0.17 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -7,17 +7,22 @@ module Builder ( buildExpressions, buildExpression, - buildExpressionFromFunction, + buildTermFromFunction, buildAttribute, buildBinding, - contextualize + contextualize, + Term (..), ) where import Ast import qualified Data.Map.Strict as Map import Matcher +import Pretty (prettyAttribute) +import Yaml (ExtraArgument (..)) +data Term = TeExpression Expression | TeAttribute Attribute + contextualize :: Expression -> Expression -> Program -> Expression contextualize ExGlobal _ (Program expr) = expr contextualize ExThis expr _ = expr @@ -100,15 +105,46 @@ _ -> Nothing buildExpression expr _ = Just (expr, defaultScope) -buildExpressionFromFunction :: String -> [Expression] -> Subst -> Program -> Maybe Expression -buildExpressionFromFunction "contextualize" [expr, context] subst prog = do +buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> Maybe Term +buildTermFromFunction "contextualize" [ArgExpression expr, ArgExpression context] subst prog = do (expr', _) <- buildExpression expr subst (context', _) <- buildExpression context subst - return (contextualize expr' context' prog) -buildExpressionFromFunction "scope" [expr] subst prog = do + return (TeExpression (contextualize expr' context' prog)) +buildTermFromFunction "scope" [ArgExpression expr] subst prog = do (expr', scope) <- buildExpression expr subst - return scope -buildExpressionFromFunction _ _ _ _ = Nothing + return (TeExpression scope) +buildTermFromFunction "random-tau" args subst _ = do + attrs <- argsToAttrs args + return (TeAttribute (AtLabel (randomTau 0 attrs))) + where + argsToAttrs :: [ExtraArgument] -> Maybe [String] + argsToAttrs [] = Just [] + argsToAttrs (arg : rest) = case arg of + ArgExpression _ -> argsToAttrs rest + ArgAttribute attr -> do + attr' <- buildAttribute attr subst + rest' <- argsToAttrs rest + Just (prettyAttribute attr' : rest') + ArgBinding bd -> do + bds <- buildBinding bd subst + rest' <- argsToAttrs rest + Just (attrsFromBindings bds ++ rest') + attrsFromBindings :: [Binding] -> [String] + attrsFromBindings [] = [] + attrsFromBindings (bd : bds) = + let attr = case bd of + BiTau attr _ -> attr + BiDelta _ -> AtDelta + BiLambda _ -> AtLambda + BiVoid attr -> attr + in prettyAttribute attr : attrsFromBindings bds + randomTau :: Integer -> [String] -> String + randomTau _ [] = cactoos + randomTau idx attrs = + let tau = if idx == 0 then cactoos else cactoos ++ show idx + in if tau `elem` attrs then randomTau (idx + 1) attrs else tau + cactoos = "a🌵" +buildTermFromFunction _ _ _ _ = Nothing -- Build a several expression from one expression and several substitutions buildExpressions :: Expression -> [Subst] -> Maybe [(Expression, Expression)] diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -16,7 +16,7 @@ import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion) -import Dataize (dataize) +import Dataize (dataize, DataizeContext (DataizeContext)) import Logger import Misc (ensuredFile) import qualified Misc @@ -24,11 +24,11 @@ import Parser (parseProgramThrows) import Paths_phino (version) import Pretty (PrintMode (SALTY, SWEET), prettyProgram') -import Rewriter (rewrite') +import Rewriter (rewrite', RewriteContext (RewriteContext)) import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf) -import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi, XmirContext (XmirContext)) +import XMIR (XmirContext (XmirContext), parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) import Yaml (normalizationRules) import qualified Yaml as Y @@ -57,6 +57,7 @@ data OptsDataize = OptsDataize { logLevel :: LogLevel, inputFormat :: IOFormat, + maxDepth :: Integer, inputFile :: Maybe FilePath } @@ -84,6 +85,9 @@ argInputFile :: Parser (Maybe FilePath) argInputFile = optional (argument str (metavar "FILE" <> help "Path to input file")) +optMaxDepth :: Parser Integer +optMaxDepth = option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault) + optInputFormat :: Parser IOFormat optInputFormat = option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format (phi, xmir)" <> value PHI <> showDefault) @@ -115,6 +119,7 @@ <$> ( OptsDataize <$> optLogLevel <*> optInputFormat + <*> optMaxDepth <*> argInputFile ) @@ -132,7 +137,7 @@ <*> switch (long "shuffle" <> help "Shuffle rules before applying") <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output") <*> switch (long "omit-comments" <> help "Omit comments in XMIR output") - <*> option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault) + <*> optMaxDepth <*> argInputFile ) @@ -169,12 +174,12 @@ setLogLevel' cmd case cmd of CmdRewrite OptsRewrite {..} -> do - when (maxDepth <= 0) $ throwIO (InvalidRewriteArguments "--max-depth must be positive") + validateMaxDepth maxDepth logDebug (printf "Amount of rewriting cycles: %d" maxDepth) input <- readInput inputFile rules' <- getRules program <- parseProgram input inputFormat - rewritten <- rewrite' program program rules' maxDepth + rewritten <- rewrite' program rules' (RewriteContext program maxDepth) logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) out <- printProgram rewritten outputFormat printMode putStrLn out @@ -209,11 +214,17 @@ xmir <- programToXMIR prog (XmirContext omitListing omitComments printMode) pure (printXMIR xmir) CmdDataize OptsDataize {..} -> do + validateMaxDepth maxDepth input <- readInput inputFile prog <- parseProgram input inputFormat - dataized <- dataize prog + dataized <- dataize prog (DataizeContext prog maxDepth) maybe (throwIO CouldNotDataize) putStrLn dataized where + validateMaxDepth :: Integer -> IO () + validateMaxDepth depth = + when + (depth <= 0) + (throwIO (InvalidRewriteArguments "--max-depth must be positive")) readInput :: Maybe FilePath -> IO String readInput inputFile' = case inputFile' of Just pth -> do diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -1,20 +1,33 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Dataize (morph, dataize, dataize') where +module Dataize (morph, dataize, dataize', DataizeContext (..), defaultDataizeContext) where import Ast -import Builder (buildExpressionFromFunction, contextualize) +import Builder (contextualize) import Condition (isNF) import Control.Exception (throwIO) import Data.List (partition) import Misc -import Rewriter (rewrite') +import Rewriter (RewriteContext (RewriteContext), rewrite') import Text.Printf (printf) +import XMIR (XmirContext (XmirContext)) import Yaml (normalizationRules) +data DataizeContext = DataizeContext + { program :: Program, + maxDepth :: Integer + } + +defaultDataizeContext :: Program -> DataizeContext +defaultDataizeContext prog = DataizeContext prog 25 + +switchContext :: DataizeContext -> RewriteContext +switchContext DataizeContext {..} = RewriteContext program maxDepth + maybeBinding :: (Binding -> Bool) -> [Binding] -> (Maybe Binding, [Binding]) maybeBinding _ [] = (Nothing, []) maybeBinding func bds = @@ -32,12 +45,12 @@ maybePhi :: [Binding] -> (Maybe Binding, [Binding]) maybePhi = maybeBinding (\case (BiTau AtPhi _) -> True; _ -> False) -formation :: [Binding] -> Program -> IO (Maybe Expression) -formation bds prog = do +formation :: [Binding] -> DataizeContext -> IO (Maybe Expression) +formation bds ctx = do let (lambda, bds') = maybeLambda bds case lambda of Just (BiLambda func) -> do - obj' <- atom func (ExFormation bds') prog + obj' <- atom func (ExFormation bds') ctx case obj' of Just obj -> pure (Just obj) _ -> pure Nothing @@ -54,26 +67,26 @@ BiTau (AtLabel attr') expr' -> if attr' == attr then Just expr' else boundExpr bds _ -> boundExpr bds -withTail :: Expression -> Program -> IO (Maybe Expression) +withTail :: Expression -> DataizeContext -> IO (Maybe Expression) withTail (ExApplication (ExFormation _) _) _ = pure Nothing withTail (ExApplication (ExDispatch ExGlobal _) _) _ = pure Nothing -withTail (ExApplication expr tau) prog = do - exp' <- withTail expr prog +withTail (ExApplication expr tau) ctx = do + exp' <- withTail expr ctx case exp' of Just exp -> pure (Just (ExApplication exp tau)) _ -> pure Nothing -withTail (ExDispatch (ExFormation bds) attr) prog = do - obj' <- formation bds prog +withTail (ExDispatch (ExFormation bds) attr) ctx = do + obj' <- formation bds ctx case obj' of Just obj -> pure (Just (ExDispatch obj attr)) _ -> pure Nothing -withTail (ExFormation bds) prog = formation bds prog -withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (Program expr) = case phiDispatch label expr of +withTail (ExFormation bds) ctx = formation bds ctx +withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (DataizeContext {program = Program expr}) = case phiDispatch label expr of Just obj -> pure (Just (ExDispatch obj attr)) _ -> pure Nothing -withTail (ExDispatch ExGlobal (AtLabel label)) (Program expr) = pure (phiDispatch label expr) -withTail (ExDispatch expr attr) prog = do - exp' <- withTail expr prog +withTail (ExDispatch ExGlobal (AtLabel label)) (DataizeContext {program = Program expr}) = pure (phiDispatch label expr) +withTail (ExDispatch expr attr) ctx = do + exp' <- withTail expr ctx case exp' of Just exp -> pure (Just (ExDispatch exp attr)) _ -> pure Nothing @@ -91,25 +104,23 @@ -- LAMBDA: M([B1, λ -> F, B2] * t) -> M(e2 * t) if e3 := [B1,B2] and e2 := F(e3) -- PHI: M(Q.tau * t) -> M(e * t) if Q -> [B1, tau -> e, B2], t is tail started with dispatch -- M(e) -> nothing otherwise --- @todo #169:30min Get rid of hard coded amount of normalization cycles. Right now the value 25 is hard coded. --- We need to pass it though function argument or global environment. -morph :: Expression -> Program -> IO (Maybe Expression) +morph :: Expression -> DataizeContext -> IO (Maybe Expression) morph ExTermination _ = pure (Just ExTermination) -- PRIM -morph (ExFormation bds) prog = do - resolved <- withTail (ExFormation bds) prog +morph (ExFormation bds) ctx = do + resolved <- withTail (ExFormation bds) ctx case resolved of - Just obj -> morph obj prog -- LAMBDA or PHI + Just obj -> morph obj ctx -- LAMBDA or PHI _ -> pure (Just (ExFormation bds)) -- PRIM -morph expr prog = do - resolved <- withTail expr prog +morph expr ctx = do + resolved <- withTail expr ctx case resolved of - Just obj -> morph obj prog + Just obj -> morph obj ctx _ -> if isNF expr then pure Nothing else do - (Program expr') <- rewrite' (Program expr) prog normalizationRules 25 -- NMZ - morph expr' prog + (Program expr') <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ + morph expr' ctx -- The goal of 'dataize' function is retrieve bytes from given expression. -- @@ -117,24 +128,24 @@ -- BOX: D([B1, 𝜑 -> e, B2]) -> D(С(e)) if [B1,B2] has no delta/lambda, where С(e) - contextualization -- NORM: D(e1) -> D(e2) if e2 := M(e1) and e1 is not primitive -- nothing otherwise -dataize :: Program -> IO (Maybe String) -dataize (Program expr) = dataize' expr (Program expr) +dataize :: Program -> DataizeContext -> IO (Maybe String) +dataize (Program expr) = dataize' expr -dataize' :: Expression -> Program -> IO (Maybe String) +dataize' :: Expression -> DataizeContext -> IO (Maybe String) dataize' ExTermination _ = pure Nothing -dataize' (ExFormation bds) prog = case maybeDelta bds of +dataize' (ExFormation bds) ctx = case maybeDelta bds of (Just (BiDelta bytes), _) -> pure (Just bytes) (Nothing, _) -> case maybePhi bds of (Just (BiTau AtPhi expr), bds') -> case maybeLambda bds' of (Just (BiLambda _), _) -> throwIO (userError "The 𝜑 and λ can't be present in formation at the same time") (_, _) -> - let expr' = contextualize expr (ExFormation bds) prog - in dataize' expr' prog + let expr' = contextualize expr (ExFormation bds) (program ctx) + in dataize' expr' ctx (Nothing, _) -> case maybeLambda bds of (Just (BiLambda _), _) -> do - morphed' <- morph (ExFormation bds) prog + morphed' <- morph (ExFormation bds) ctx case morphed' of - Just morphed -> dataize' morphed prog + Just morphed -> dataize' morphed ctx _ -> pure Nothing (Nothing, _) -> pure Nothing dataize' expr prog = do @@ -146,10 +157,10 @@ toDouble :: Integer -> Double toDouble = fromIntegral -atom :: String -> Expression -> Program -> IO (Maybe Expression) -atom "L_org_eolang_number_plus" self prog = do - left <- dataize' (ExDispatch self (AtLabel "x")) prog - right <- dataize' (ExDispatch self AtRho) prog +atom :: String -> Expression -> DataizeContext -> IO (Maybe Expression) +atom "L_org_eolang_number_plus" self ctx = do + left <- dataize' (ExDispatch self (AtLabel "x")) ctx + right <- dataize' (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (hexToNum left') @@ -157,9 +168,9 @@ sum = first + second pure (Just (DataObject "number" (numToHex sum))) _ -> pure Nothing -atom "L_org_eolang_number_times" self prog = do - left <- dataize' (ExDispatch self (AtLabel "x")) prog - right <- dataize' (ExDispatch self AtRho) prog +atom "L_org_eolang_number_times" self ctx = do + left <- dataize' (ExDispatch self (AtLabel "x")) ctx + right <- dataize' (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (hexToNum left') @@ -167,9 +178,9 @@ sum = first * second pure (Just (DataObject "number" (numToHex sum))) _ -> pure Nothing -atom "L_org_eolang_number_eq" self prog = do - x <- dataize' (ExDispatch self (AtLabel "x")) prog - rho <- dataize' (ExDispatch self AtRho) prog +atom "L_org_eolang_number_eq" self ctx = do + x <- dataize' (ExDispatch self (AtLabel "x")) ctx + rho <- dataize' (ExDispatch self AtRho) ctx case (x, rho) of (Just x', Just rho') -> do let self' = either toDouble id (hexToNum rho') diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -51,6 +51,8 @@ pretty (AtAlpha index) = pretty "α" <> pretty index pretty AtRho = pretty "ρ" pretty AtPhi = pretty "φ" + pretty AtDelta = pretty "Δ" + pretty AtLambda = pretty "λ" pretty (AtMeta meta) = prettyMeta meta instance Pretty (Formatted Binding) where @@ -69,6 +71,7 @@ BiVoid attr -> attr : voids bds _ -> [] inlineVoids :: [Attribute] -> Doc ann + inlineVoids [] = pretty attr <+> prettyArrow inlineVoids voids' = pretty attr <> lparen <> hsep (punctuate comma (map pretty voids')) <> rparen <+> prettyArrow pretty (Formatted (mode, BiTau attr expr)) = pretty attr <+> prettyArrow <+> pretty (Formatted (mode, expr)) pretty (Formatted (_, BiMeta meta)) = prettyMeta meta diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -6,7 +6,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, rewrite') where +module Rewriter (rewrite, rewrite', RewriteContext (..), defaultRewriteContext) where import Ast import Builder @@ -14,15 +14,25 @@ import Control.Exception import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) +import Debug.Trace (trace) import Logger (logDebug) import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows) -import Pretty (PrintMode (SWEET), prettyExpression, prettyProgram, prettyProgram', prettySubsts) +import Pretty (PrintMode (SWEET), prettyAttribute, prettyExpression, prettyProgram, prettyProgram', prettySubsts) import Replacer (replaceProgram) import Text.Printf +import Yaml (ExtraArgument (..)) import qualified Yaml as Y +data RewriteContext = RewriteContext + { program :: Program, + maxDepth :: Integer + } + +defaultRewriteContext :: Program -> RewriteContext +defaultRewriteContext prog = RewriteContext prog 25 + data RewriteException = CouldNotBuild {expr :: Expression, substs :: [Subst]} | CouldNotReplace {prog :: Program, ptn :: Expression, res :: Expression} @@ -61,23 +71,25 @@ Just extras' -> catMaybes [ foldl - ( \(Just subst') extra -> case Y.meta extra of - ExMeta name -> do - let func = Y.function extra - args = Y.args extra - expr <- buildExpressionFromFunction func args subst' prog - combine (substSingle name (MvExpression expr defaultScope)) subst' - _ -> Just subst' + ( \(Just subst') extra -> do + name <- case Y.meta extra of + ArgExpression (ExMeta name) -> Just name + ArgAttribute (AtMeta name) -> Just name + ArgBinding (BiMeta name) -> Just name + _ -> Nothing + let func = Y.function extra + args = Y.args extra + term <- buildTermFromFunction func args subst' prog + let meta = case term of + TeExpression expr -> MvExpression expr defaultScope + TeAttribute attr -> MvAttribute attr + combine (substSingle name meta) subst' ) (Just subst) extras' | subst <- substs ] --- @todo #169:30min Make original program global. There are some many places where we --- need access to original program like here, in Rewriter. Also it's needed in Builder and Dataize modules. --- Right now we pass this original program as argument. Maybe it would be better to move it to some global state --- since it's not changed during whole program processing. rewrite :: Program -> Program -> [Y.Rule] -> IO Program rewrite program _ [] = pure program rewrite program program' (rule : rest) = do @@ -93,14 +105,15 @@ pure prog' rewrite prog program' rest --- @todo #169:30min Stop counting amount of rewriting cycles. Right now in order not to +-- @todo #169:30min Memorize previous rewritten programs. Right now in order not to -- get an infinite recursion during rewriting we just count have many times we apply -- rewriting rules. If we reach given amount - we just stop. It's not idiomatic and may -- not work on big programs. We need to introduce some mechanism which would memorize -- all rewritten program on each step and if on some step we get the program that have already --- been memorized - we fail because we got into infinite recursion. -rewrite' :: Program -> Program -> [Y.Rule] -> Integer -> IO Program -rewrite' prog prog' rules maxDepth = _rewrite prog 0 +-- been memorized - we fail because we got into infinite recursion. Ofc we should keep counting +-- rewriting cycles if program just only grows on each rewriting. +rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO Program +rewrite' prog rules RewriteContext {..} = _rewrite prog 0 where _rewrite :: Program -> Integer -> IO Program _rewrite prog count = do @@ -110,7 +123,7 @@ logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped") pure prog else do - rewritten <- rewrite prog prog' rules + rewritten <- rewrite prog program rules if rewritten == prog then do logDebug "Rewriting is stopped since it does not affect program anymore" diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -217,12 +217,12 @@ (Prologue [] Nothing []) ( element "object" - [ ("xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance"), - ("dob", formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now), + [ ("dob", formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now), ("ms", "0"), ("revision", "1234567"), ("time", time now), ("version", showVersion version), + ("xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance"), ("xsi:noNamespaceSchemaLocation", "https://raw.githubusercontent.com/objectionary/eo/refs/heads/gh-pages/XMIR.xsd") ] ( if null pckg diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -29,9 +29,6 @@ Right parsed -> pure parsed ) -instance FromJSON Expression where - parseJSON = parseJSON' "Expression" parseExpression - instance FromJSON Attribute where parseJSON = withText @@ -44,6 +41,9 @@ Right attr -> pure attr ) +instance FromJSON Expression where + parseJSON = parseJSON' "Expression" parseExpression + instance FromJSON Binding where parseJSON = parseJSON' "Binding" parseBinding @@ -93,6 +93,14 @@ ] ) +instance FromJSON ExtraArgument where + parseJSON v = + asum + [ ArgAttribute <$> parseJSON v, + ArgBinding <$> parseJSON v, + ArgExpression <$> parseJSON v + ] + instance FromJSON Extra where parseJSON = genericParseJSON defaultOptions @@ -127,10 +135,16 @@ | XI Expression deriving (Generic, Show) +data ExtraArgument + = ArgAttribute Attribute + | ArgExpression Expression + | ArgBinding Binding + deriving (Generic, Show) + data Extra = Extra - { meta :: Expression, + { meta :: ExtraArgument, function :: String, - args :: [Expression] + args :: [ExtraArgument] } deriving (Generic, Show) diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -5,23 +5,23 @@ import Ast (Attribute (AtLabel, AtPhi, AtRho), Binding (BiDelta, BiTau, BiVoid), Expression (ExApplication, ExDispatch, ExFormation, ExGlobal, ExTermination, ExThis), Program (Program)) import Control.Monad -import Dataize (dataize, dataize', morph) +import Dataize (dataize, dataize', morph, defaultDataizeContext, DataizeContext) import Parser (parseProgramThrows) import Test.Hspec -test :: (Eq a, Show a) => (Expression -> Program -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec +test :: (Eq a, Show a) => (Expression -> DataizeContext -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec test func useCases = forM_ useCases $ \(desc, input, prog, output) -> it desc $ do - res <- func input (Program prog) + res <- func input (defaultDataizeContext (Program prog)) res `shouldBe` output testDataize :: [(String, String, String)] -> Spec testDataize useCases = forM_ useCases $ \(name, prog, res) -> it name $ do - program <- parseProgramThrows prog - value <- dataize program + prog' <- parseProgramThrows prog + value <- dataize prog' (defaultDataizeContext prog') value `shouldBe` Just res spec :: Spec diff --git a/test/PrettySpec.hs b/test/PrettySpec.hs --- a/test/PrettySpec.hs +++ b/test/PrettySpec.hs @@ -53,7 +53,8 @@ ("Q -> Q.x(~0 -> Q.y)", "{Φ.x(\n Φ.y\n)}"), ("Q -> Q.x(~0 -> 1)(~1 -> 2)(~2 -> 3)", "{Φ.x(\n 1,\n 2,\n 3\n)}"), ("Q -> Q.x(~0 -> 1)(~2 -> 2)(~1 -> 3)", "{Φ.x(\n α0 ↦ 1,\n α2 ↦ 2,\n α1 ↦ 3\n)}"), - ("Q -> Φ.jeo.opcode.ldc(18, \"Reading \\\"\")", "{Φ.jeo.opcode.ldc(\n 18,\n \"Reading \\\"\"\n)}") + ("Q -> Φ.jeo.opcode.ldc(18, \"Reading \\\"\")", "{Φ.jeo.opcode.ldc(\n 18,\n \"Reading \\\"\"\n)}"), + ("Q -> [[ k -> [[]] ]]", "{⟦\n k ↦ ⟦⟧\n⟧}") ] test prettyProgram' useCases diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -20,7 +20,7 @@ import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) import Yaml qualified as Y -import Rewriter (rewrite') +import Rewriter (rewrite', RewriteContext (RewriteContext)) data Rules = Rules { basic :: Maybe [String], @@ -91,7 +91,7 @@ if normalize' then pure normalizationRules else pure [] - rewritten <- rewrite' program program rules' repeat' + rewritten <- rewrite' program rules' (RewriteContext program repeat') result' <- parseProgramThrows (output pack) unless (rewritten == result') $ expectationFailure