packages feed

phino 0.0.0.14 → 0.0.0.15

raw patch · 16 files changed

+538/−200 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Builder: contextualize :: Expression -> Expression -> Program -> Expression
+ Condition: isNF :: Expression -> Bool
+ Condition: matchesAnyNormalizationRule :: Expression -> Bool
+ Dataize: dataize :: Program -> IO (Maybe String)
+ Dataize: dataize' :: Expression -> Program -> IO (Maybe String)
+ Dataize: morph :: Expression -> Program -> IO (Maybe Expression)
+ Matcher: defaultScope :: Expression
+ Rewriter: rewrite' :: Program -> Program -> [Rule] -> Integer -> IO Program
- Rewriter: rewrite :: Program -> [Rule] -> IO Program
+ Rewriter: rewrite :: Program -> Program -> [Rule] -> IO Program

Files

phino.cabal view
@@ -1,7 +1,7 @@ cabal-version:      3.0  name:               phino-version:            0.0.0.14+version:            0.0.0.15 license:            MIT synopsis:           Command-Line Manipulator of 𝜑-Calculus Expressions description:        Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -33,6 +33,7 @@     Rewriter,     Yaml,     Condition,+    Dataize,     Misc,     Logger,     Pretty,@@ -94,6 +95,7 @@     MiscSpec,     XMIRSpec,     HLintSpec,+    DataizeSpec,     Paths_phino   autogen-modules:     Paths_phino
src/Builder.hs view
@@ -10,6 +10,7 @@     buildExpressionFromFunction,     buildAttribute,     buildBinding,+    contextualize   ) where @@ -70,6 +71,11 @@   TaApplication taus -> buildExpressionWithTails (ExApplication expr taus) rest subst   TaDispatch attr -> buildExpressionWithTails (ExDispatch expr attr) rest subst +-- Build meta expression with given substitution+-- It returns tuple (X, Y)+-- where X is built expression and Y is context of X+-- If meta expression is built from MvExpression, is has+-- context from original Program. It have default context otherwise buildExpression :: Expression -> Subst -> Maybe (Expression, Expression) buildExpression (ExDispatch expr attr) subst = do   (dispatched, scope) <- buildExpression expr subst@@ -82,7 +88,7 @@ buildExpression (ExApplication _ _) _ = Nothing buildExpression (ExFormation bds) subst = do   bds' <- buildBindings bds subst-  Just (ExFormation bds', ExFormation [])+  Just (ExFormation bds', defaultScope) buildExpression (ExMeta meta) (Subst mp) = case Map.lookup meta mp of   Just (MvExpression expr scope) -> Just (expr, scope)   _ -> Nothing@@ -92,7 +98,7 @@   case Map.lookup meta mp of     Just (MvTail tails) -> Just (buildExpressionWithTails expression tails subst, scope)     _ -> Nothing-buildExpression expr _ = Just (expr, ExFormation [])+buildExpression expr _ = Just (expr, defaultScope)  buildExpressionFromFunction :: String -> [Expression] -> Subst -> Program -> Maybe Expression buildExpressionFromFunction "contextualize" [expr, context] subst prog = do
src/CLI.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,6 +16,7 @@ import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion)+import Dataize (dataize) import Logger import Misc (ensuredFile) import qualified Misc@@ -21,29 +24,28 @@ import Parser (parseProgramThrows) import Paths_phino (version) import Pretty (PrintMode (SALTY, SWEET), prettyProgram')-import Rewriter (rewrite)+import Rewriter (rewrite') import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf)-import XMIR (printXMIR, programToXMIR, parseXMIRThrows, xmirToPhi)+import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) import Yaml (normalizationRules) import qualified Yaml as Y  data CmdException   = InvalidRewriteArguments {message :: String}   | CouldNotReadFromStdin {message :: String}+  | CouldNotDataize   deriving (Exception)  instance Show CmdException where   show InvalidRewriteArguments {..} = printf "Invalid set of arguments for 'rewrite' command: %s" message   show CouldNotReadFromStdin {..} = printf "Could not read input from stdin\nReason: %s" message--data App = App-  { logLevel :: LogLevel,-    cmd :: Command-  }+  show CouldNotDataize = "Could not dataize given program" -newtype Command = CmdRewrite OptsRewrite+data Command+  = CmdRewrite OptsRewrite+  | CmdDataize OptsDataize  data IOFormat = XMIR | PHI   deriving (Eq)@@ -52,8 +54,14 @@   show XMIR = "xmir"   show PHI = "phi" +data OptsDataize = OptsDataize+  { logLevel :: LogLevel,+    inputFormat :: IOFormat,+    inputFile :: Maybe FilePath+  }+ data OptsRewrite = OptsRewrite-  { inputFile :: Maybe FilePath,+  { logLevel :: LogLevel,     rules :: [FilePath],     inputFormat :: IOFormat,     outputFormat :: IOFormat,@@ -62,62 +70,81 @@     nothing :: Bool,     shuffle :: Bool,     omitListing :: Bool,-    maxDepth :: Integer+    maxDepth :: Integer,+    inputFile :: Maybe FilePath   }  parseIOFormat :: String -> ReadM IOFormat parseIOFormat type' = eitherReader $ \format -> case map toLower format of   "xmir" -> Right XMIR   "phi" -> Right PHI-  _ -> Left (printf "invalid %s format: expected 'xmir' or 'phi'" type')+  _ -> Left (printf "invalid %s format: expected '%s' or '%s'" type' (show PHI) (show XMIR)) +argInputFile :: Parser (Maybe FilePath)+argInputFile = optional (argument str (metavar "FILE" <> help "Path to input file"))++optInputFormat :: Parser IOFormat+optInputFormat = option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format (phi, xmir)" <> value PHI <> showDefault)++optLogLevel :: Parser LogLevel+optLogLevel =+  option+    parseLogLevel+    ( long "log-level"+        <> metavar "LEVEL"+        <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")")+        <> value INFO+        <> showDefault+    )+  where+    parseLogLevel :: ReadM LogLevel+    parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of+      "DEBUG" -> Right DEBUG+      "INFO" -> Right INFO+      "WARNING" -> Right WARNING+      "WARN" -> Right WARNING+      "ERROR" -> Right ERROR+      "ERR" -> Right ERROR+      "NONE" -> Right NONE+      _ -> Left $ "unknown log-level: " <> lvl++dataizeParser :: Parser Command+dataizeParser =+  CmdDataize+    <$> ( OptsDataize+            <$> optLogLevel+            <*> optInputFormat+            <*> argInputFile+        )+ rewriteParser :: Parser Command rewriteParser =   CmdRewrite     <$> ( OptsRewrite-            <$> optional (argument str (metavar "FILE" <> help "Path to input file"))+            <$> optLogLevel             <*> many (strOption (long "rule" <> metavar "FILE" <> help "Path to custom rule"))-            <*> option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format" <> value PHI <> showDefault)-            <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format" <> value PHI <> showDefault)+            <*> optInputFormat+            <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format (phi, xmir)" <> value PHI <> showDefault)             <*> flag SALTY SWEET (long "sweet" <> help "Print 𝜑-program using syntax sugar")             <*> switch (long "normalize" <> help "Use built-in normalization rules")             <*> switch (long "nothing" <> help "Just desugar provided 𝜑-program")             <*> switch (long "shuffle" <> help "Shuffle rules before applying")             <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output")             <*> option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault)+            <*> argInputFile         )  commandParser :: Parser Command-commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression")))--parseLogLevel :: ReadM LogLevel-parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of-  "DEBUG" -> Right DEBUG-  "INFO" -> Right INFO-  "WARNING" -> Right WARNING-  "WARN" -> Right WARNING-  "ERROR" -> Right ERROR-  "ERR" -> Right ERROR-  "NONE" -> Right NONE-  _ -> Left $ "unknown log-level: " <> lvl--appParser :: Parser App-appParser =-  App-    <$> option-      parseLogLevel-      ( long "log-level"-          <> metavar "LEVEL"-          <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")")-          <> value INFO-          <> showDefault-      )-    <*> commandParser+commandParser =+  hsubparser+    ( command "rewrite" (info (rewriteParser <**> helper) (progDesc "Rewrite the program"))+        <> command "dataize" (info (dataizeParser <**> helper) (progDesc "Dataize the program"))+    ) -parserInfo :: ParserInfo App+parserInfo :: ParserInfo Command parserInfo =   info-    (appParser <**> helper <**> simpleVersioner (showVersion version))+    (commandParser <**> helper <**> simpleVersioner (showVersion version))     (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions")  handler :: SomeException -> IO ()@@ -127,31 +154,29 @@     logError (displayException e)     exitFailure +setLogLevel' :: Command -> IO ()+setLogLevel' cmd =+  let level = case cmd of+        CmdRewrite OptsRewrite {logLevel} -> logLevel+        CmdDataize OptsDataize {logLevel} -> logLevel+   in setLogLevel level+ runCLI :: [String] -> IO () runCLI args = handle handler $ do-  App {..} <- handleParseResult (execParserPure defaultPrefs parserInfo args)-  setLogLevel logLevel+  cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args)+  setLogLevel' cmd   case cmd of     CmdRewrite OptsRewrite {..} -> do       when (maxDepth <= 0) $ throwIO (InvalidRewriteArguments "--max-depth must be positive")       logDebug (printf "Amount of rewriting cycles: %d" maxDepth)-      input <- readInput+      input <- readInput inputFile       rules' <- getRules       program <- parseProgram input inputFormat-      rewritten <- rewrite' program rules' 1+      rewritten <- rewrite' program program rules' maxDepth       logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat))       out <- printProgram rewritten outputFormat printMode       putStrLn out       where-        readInput :: IO String-        readInput = case inputFile of-          Just pth -> do-            logDebug (printf "Reading from file: '%s'" pth)-            readFile =<< ensuredFile pth-          Nothing -> do-            logDebug "Reading from stdin"-            getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))-         getRules :: IO [Y.Rule]         getRules = do           ordered <-@@ -176,30 +201,27 @@               logDebug "The --shuffle option is provided, rules are used in random order"               Misc.shuffle ordered             else pure ordered--        parseProgram :: String -> IOFormat -> IO Program-        parseProgram phi PHI = parseProgramThrows phi-        parseProgram xmir XMIR = do-          doc <- parseXMIRThrows xmir-          xmirToPhi doc--        rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program-        rewrite' prog rules count = do-          logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth)-          if count == maxDepth-            then do-              logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped")-              pure prog-            else do-              rewritten <- rewrite prog rules-              if rewritten == prog-                then do-                  logDebug "Rewriting is stopped since it does not affect program anymore"-                  pure rewritten-                else rewrite' rewritten rules (count + 1)-         printProgram :: Program -> IOFormat -> PrintMode -> IO String         printProgram prog PHI mode = pure (prettyProgram' prog mode)         printProgram prog XMIR mode = do           xmir <- programToXMIR prog mode omitListing           pure (printXMIR xmir)+    CmdDataize OptsDataize {..} -> do+      input <- readInput inputFile+      prog <- parseProgram input inputFormat+      dataized <- dataize prog+      maybe (throwIO CouldNotDataize) putStrLn dataized+  where+    readInput :: Maybe FilePath -> IO String+    readInput inputFile' = case inputFile' of+      Just pth -> do+        logDebug (printf "Reading from file: '%s'" pth)+        readFile =<< ensuredFile pth+      Nothing -> do+        logDebug "Reading from stdin"+        getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))+    parseProgram :: String -> IOFormat -> IO Program+    parseProgram phi PHI = parseProgramThrows phi+    parseProgram xmir XMIR = do+      doc <- parseXMIRThrows xmir+      xmirToPhi doc
src/Condition.hs view
@@ -49,6 +49,41 @@ numToInt (Y.Literal num) subst = Just num numToInt _ _ = Nothing +-- Returns True if given expression matches with any of given normalization rules+matchesAnyNormalizationRule :: Expression -> Bool+matchesAnyNormalizationRule expr = matchesAnyNormalizationRule' expr normalizationRules+  where+    matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> Bool+    matchesAnyNormalizationRule' _ [] = False+    matchesAnyNormalizationRule' expr (rule : rules) =+      case matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr) of+        Just matched -> not (null matched) || matchesAnyNormalizationRule' expr rules+        Nothing -> matchesAnyNormalizationRule' expr rules++-- Returns True if given expression is in the normal form+isNF :: Expression -> Bool+isNF ExThis = True+isNF ExGlobal = True+isNF ExTermination = True+isNF (ExDispatch ExThis _) = True+isNF (ExDispatch ExGlobal _) = True+isNF (ExDispatch ExTermination _) = False -- dd rule+isNF (ExApplication ExTermination _) = False -- dc rule+isNF (ExFormation []) = True+isNF (ExFormation bds) = normalBindings bds || not (matchesAnyNormalizationRule (ExFormation bds))+  where+    -- Returns True if all given bindings are 100% in normal form+    normalBindings :: [Binding] -> Bool+    normalBindings [] = True+    normalBindings (bd : bds) =+      let next = normalBindings bds+       in case bd of+            BiDelta _ -> next+            BiVoid _ -> next+            BiLambda _ -> next+            _ -> False+isNF expr = not (matchesAnyNormalizationRule expr)+ meetCondition' :: Y.Condition -> Subst -> [Subst] meetCondition' (Y.Or []) subst = [subst] meetCondition' (Y.Or (cond : rest)) subst =@@ -80,38 +115,9 @@ meetCondition' (Y.Eq (Y.CmpAttr left) (Y.CmpAttr right)) subst = [subst | compareAttrs left right subst] meetCondition' (Y.Eq _ _) _ = [] meetCondition' (Y.NF (ExMeta meta)) (Subst mp) = case M.lookup meta mp of-  Just (MvExpression expr _) ->-    let isNf = not (matchesAnyNormalizationRule expr normalizationRules)-     in case expr of-          ExThis -> [Subst mp]-          ExGlobal -> [Subst mp]-          ExTermination -> [Subst mp]-          ExDispatch ExThis _ -> [Subst mp]-          ExDispatch ExGlobal _ -> [Subst mp]-          ExDispatch ExTermination _ -> [] -- dd rule-          ExApplication ExTermination _ -> [] -- dc rule-          ExFormation [] -> [Subst mp]-          ExFormation bds -> [Subst mp | normalBindings bds || isNf]-          _ -> [Subst mp | isNf]+  Just (MvExpression expr _) -> [Subst mp | isNF expr]   _ -> []-  where-    -- Returns True if given expression matches with any of given normalization rules-    matchesAnyNormalizationRule :: Expression -> [Y.Rule] -> Bool-    matchesAnyNormalizationRule _ [] = False-    matchesAnyNormalizationRule expr (rule : rules) =-      case matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr) of-        Just matched -> not (null matched) || matchesAnyNormalizationRule expr rules-        Nothing -> matchesAnyNormalizationRule expr rules-    normalBindings :: [Binding] -> Bool-    normalBindings [] = True-    normalBindings (bd : bds) =-      let next = normalBindings bds-       in case bd of-            BiDelta _ -> next-            BiVoid _ -> next-            BiLambda _ -> next-            _ -> False-meetCondition' (Y.NF _) _ = []+meetCondition' (Y.NF expr) (Subst mp) = [Subst mp | isNF expr] meetCondition' (Y.XI (ExMeta meta)) (Subst mp) = case M.lookup meta mp of   Just (MvExpression expr _) -> meetCondition' (Y.XI expr) (Subst mp)   _ -> []
+ src/Dataize.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE LambdaCase #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Dataize (morph, dataize, dataize') where++import Ast+import Builder (buildExpressionFromFunction, contextualize)+import Condition (isNF)+import Control.Exception (throwIO)+import Data.List (partition)+import Misc+import Rewriter (rewrite')+import Text.Printf (printf)+import Yaml (normalizationRules)++maybeBinding :: (Binding -> Bool) -> [Binding] -> (Maybe Binding, [Binding])+maybeBinding _ [] = (Nothing, [])+maybeBinding func bds =+  let (found, rest) = partition func bds+   in case found of+        [bd] -> (Just bd, rest)+        _ -> (Nothing, bds)++maybeLambda :: [Binding] -> (Maybe Binding, [Binding])+maybeLambda = maybeBinding (\case BiLambda _ -> True; _ -> False)++maybeDelta :: [Binding] -> (Maybe Binding, [Binding])+maybeDelta = maybeBinding (\case BiDelta _ -> True; _ -> False)++maybePhi :: [Binding] -> (Maybe Binding, [Binding])+maybePhi = maybeBinding (\case (BiTau AtPhi _) -> True; _ -> False)++formation :: [Binding] -> Program -> IO (Maybe Expression)+formation bds prog = do+  let (lambda, bds') = maybeLambda bds+  case lambda of+    Just (BiLambda func) -> do+      obj' <- atom func (ExFormation bds') prog+      case obj' of+        Just obj -> pure (Just obj)+        _ -> pure Nothing+    _ -> pure Nothing++phiDispatch :: String -> Expression -> Maybe Expression+phiDispatch attr expr = case expr of+  ExFormation bds -> boundExpr bds+  _ -> Nothing+  where+    boundExpr :: [Binding] -> Maybe Expression+    boundExpr [] = Nothing+    boundExpr (bd : bds) = case bd of+      BiTau (AtLabel attr') expr' -> if attr' == attr then Just expr' else boundExpr bds+      _ -> boundExpr bds++withTail :: Expression -> Program -> IO (Maybe Expression)+withTail (ExApplication (ExFormation _) _) _ = pure Nothing+withTail (ExApplication (ExDispatch ExGlobal _) _) _ = pure Nothing+withTail (ExApplication expr tau) prog = do+  exp' <- withTail expr prog+  case exp' of+    Just exp -> pure (Just (ExApplication exp tau))+    _ -> pure Nothing+withTail (ExDispatch (ExFormation bds) attr) prog = do+  obj' <- formation bds prog+  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+  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+  case exp' of+    Just exp -> pure (Just (ExDispatch exp attr))+    _ -> pure Nothing+withTail _ _ = pure Nothing++-- The Morphing function M:<B,S> -> <P,S> maps objects to+-- primitives, possibly modifying the state of evaluation.+-- Terminology:+-- P(e) - is e Primitive, which is either formation without λ binding or termination ⊥+-- N(e) - normalize e+-- NF(e) - is e in normal form (can't be normalized anymore)+--+-- PRIM:   M(e) -> e                              if P(e)+-- NMZ:    M(e1) -> M(e2)                         if e2 := N(e1) and e1 != e2+-- 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 ExTermination _ = pure (Just ExTermination) -- PRIM+morph (ExFormation bds) prog = do+  resolved <- withTail (ExFormation bds) prog+  case resolved of+    Just obj -> morph obj prog -- LAMBDA or PHI+    _ -> pure (Just (ExFormation bds)) -- PRIM+morph expr prog = do+  resolved <- withTail expr prog+  case resolved of+    Just obj -> morph obj prog+    _ ->+      if isNF expr+        then pure Nothing+        else do+          (Program expr') <- rewrite' (Program expr) prog normalizationRules 25 -- NMZ+          morph expr' prog++-- The goal of 'dataize' function is retrieve bytes from given expression.+--+-- DELTA: D(e) -> data                          if e = [B1, Δ -> data, B2]+-- 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' :: Expression -> Program -> IO (Maybe String)+dataize' ExTermination _ = pure Nothing+dataize' (ExFormation bds) prog = 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+    (Nothing, _) -> case maybeLambda bds of+      (Just (BiLambda _), _) -> do+        morphed' <- morph (ExFormation bds) prog+        case morphed' of+          Just morphed -> dataize' morphed prog+          _ -> pure Nothing+      (Nothing, _) -> pure Nothing+dataize' expr prog = do+  morphed' <- morph expr prog+  case morphed' of+    Just morphed -> dataize' morphed prog+    _ -> pure Nothing++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+  case (left, right) of+    (Just left', Just right') -> do+      let first = either toDouble id (hexToNum left')+          second = either toDouble id (hexToNum right')+          sum = first + second+      pure (Just (DataObject "number" (numToHex sum)))+    _ -> pure Nothing+  where+    toDouble :: Integer -> Double+    toDouble = fromIntegral+atom func _ _ = throwIO (userError (printf "Atom '%s' does not exist" func))
src/Logger.hs view
@@ -27,7 +27,7 @@  logger :: IORef Logger {-# NOINLINE logger #-}-logger = unsafePerformIO (newIORef (Logger INFO))+logger = unsafePerformIO (newIORef (Logger DEBUG))  setLogLevel :: LogLevel -> IO () setLogLevel lvl = writeIORef logger (Logger lvl)
src/Matcher.hs view
@@ -41,6 +41,9 @@ substSingle :: String -> MetaValue -> Subst substSingle key value = Subst (Map.singleton key value) +defaultScope :: Expression+defaultScope = ExFormation [BiVoid AtRho]+ -- Combine two substitutions into a single one -- Fails if values by the same keys are not equal combine :: Subst -> Subst -> Maybe Subst@@ -141,4 +144,4 @@    in matched ++ deep  matchProgram :: Expression -> Program -> [Subst]-matchProgram ptn (Program exp) = matchExpressionDeep ptn exp (ExFormation [BiVoid AtRho])+matchProgram ptn (Program exp) = matchExpressionDeep ptn exp defaultScope
src/Misc.hs view
@@ -215,8 +215,8 @@ -- "" -- >>> hexToStr "68-22" -- "h\\\""--- >>> hexToStr "01-01"--- "\\x01\\x01"+-- >>> hexToStr "01-02"+-- "\\x01\\x02" hexToStr :: String -> String hexToStr "--" = "" hexToStr [] = ""@@ -241,7 +241,7 @@ -- The function is generated by ChatGPT and claimed as -- fastest approach comparing to usage IOArray. -- >>> shuffle [1..20]--- [20,5,6,1,12,10,7,8,9,11,14,15,13,2,4,16,3,19,18,17]+-- [12,15,5,14,1,7,17,10,9,16,13,11,6,4,18,2,19,20,3,8] shuffle :: [a] -> IO [a] shuffle xs = do   gen <- newIOGenM =<< newStdGen
src/Rewriter.hs view
@@ -6,7 +6,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite) where+module Rewriter (rewrite, rewrite') where  import Ast import Builder@@ -15,10 +15,10 @@ import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) import Logger (logDebug)-import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, matchProgram, substEmpty, substSingle)+import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows)-import Pretty (prettyExpression, prettyProgram, prettySubsts)+import Pretty (PrintMode (SWEET), prettyExpression, prettyProgram, prettyProgram', prettySubsts) import Replacer (replaceProgram) import Text.Printf import qualified Yaml as Y@@ -66,7 +66,7 @@                 let func = Y.function extra                     args = Y.args extra                 expr <- buildExpressionFromFunction func args subst' prog-                combine (substSingle name (MvExpression expr (ExFormation []))) subst'+                combine (substSingle name (MvExpression expr defaultScope)) subst'               _ -> Just subst'           )           (Just subst)@@ -74,19 +74,45 @@         | subst <- substs       ] -rewrite :: Program -> [Y.Rule] -> IO Program-rewrite program [] = pure program-rewrite program (rule : rest) = do-  logDebug (printf "Trying to apply rule: %s" (fromMaybe "unknown" (Y.name rule)))+-- @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   let ptn = Y.pattern rule       res = Y.result rule       condition = Y.when rule   prog <- case C.matchProgramWithCondition ptn condition program of-    Nothing -> do-      logDebug "Rule didn't match"-      pure program+    Nothing -> pure program     Just matched -> do-      let substs = extraSubstitutions program (Y.where_ rule) matched-      logDebug (printf "Rule has been matched, substitutions are:\n%s" (prettySubsts substs))-      buildAndReplace program ptn res substs-  rewrite prog rest+      let substs = extraSubstitutions program' (Y.where_ rule) matched+      prog' <- buildAndReplace program ptn res substs+      logDebug (printf "%s\n%s" (fromMaybe "unknown" (Y.name rule)) (prettyProgram' prog' SWEET))+      pure prog'+  rewrite prog program' rest++-- @todo #169:30min Stop counting amount of rewriting cycles. 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+  where+    _rewrite :: Program -> Integer -> IO Program+    _rewrite prog count = do+      logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth)+      if count == maxDepth+        then do+          logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped")+          pure prog+        else do+          rewritten <- rewrite prog prog' rules+          if rewritten == prog+            then do+              logDebug "Rewriting is stopped since it does not affect program anymore"+              pure rewritten+            else _rewrite rewritten (count + 1)
src/XMIR.hs view
@@ -270,10 +270,17 @@     printRawText (NodeContent t) = TB.fromText t     printRawText _ = mempty +-- >>> printNode 0 (NodeComment (T.pack "--hello--"))+-- "<!-- &#45;&#45;hello&#45;&#45; -->\n" printNode :: Int -> Node -> TB.Builder printNode _ (NodeContent t) = TB.fromText t -- print text exactly as-is printNode i (NodeElement e) = printElement i e -- pretty-print elements-printNode i (NodeComment t) = indent i <> TB.fromString "<!-- " <> TB.fromText t <> TB.fromString " -->" <> newline+printNode i (NodeComment t) =+  indent i+    <> TB.fromString "<!-- "+    <> TB.fromText (T.replace "--" "&#45;&#45;" t)+    <> TB.fromString " -->"+    <> newline printNode _ _ = mempty  printXMIR :: Document -> String
test/BuilderSpec.hs view
@@ -23,12 +23,12 @@       [ ( "Q.!a => (!a >> x) => Q.x",           ExDispatch ExGlobal (AtMeta "a"),           [("a", MvAttribute (AtLabel "x"))],-          Just (ExDispatch ExGlobal (AtLabel "x"), ExFormation [])+          Just (ExDispatch ExGlobal (AtLabel "x"), defaultScope)         ),         ( "Q.c(!a -> !e) => (!a >> x, !e >> $.y.z) => Q.c(x -> $.y.z)",           ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtMeta "a") (ExMeta "e")),-          [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")) (ExFormation []))],-          Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))), ExFormation [])+          [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")) defaultScope)],+          Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))), defaultScope)         ),         ( "[[!a -> $.x, !B]] => (!a >> y, !B >> [[b -> ?, L> Func]]) => [[y -> $.x, b -> ?, L> Func]]",           ExFormation [BiTau (AtMeta "a") (ExDispatch ExThis (AtLabel "x")), BiMeta "B"],@@ -39,13 +39,13 @@                   BiVoid (AtLabel "b"),                   BiLambda "Func"                 ],-              ExFormation []+              defaultScope             )         ),         ( "Q * !t => (!t >> [.a, .b, (~1 -> $.x)]) => Q.a.b(~1 -> $.x)",           ExMetaTail ExGlobal "t",           [("t", MvTail [TaDispatch (AtLabel "a"), TaDispatch (AtLabel "b"), TaApplication (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x")))])],-          Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))), ExFormation [])+          Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))), defaultScope)         ),         ( "Q.!a => () => X",           ExDispatch ExGlobal (AtMeta "a"),@@ -54,13 +54,13 @@         ),         ( "!e0(!a1 -> !e1, !a2 => !e2) => (!e0 >> [[]], !a1 >> x, !e1 >> Q, !a2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)",           ExApplication (ExApplication (ExMeta "e0") (BiTau (AtMeta "a1") (ExMeta "e1"))) (BiTau (AtMeta "a2") (ExMeta "e2")),-          [ ("e0", MvExpression (ExFormation []) (ExFormation [])),+          [ ("e0", MvExpression (ExFormation []) defaultScope),             ("a1", MvAttribute (AtLabel "x")),-            ("e1", MvExpression ExGlobal (ExFormation [])),+            ("e1", MvExpression ExGlobal defaultScope),             ("a2", MvAttribute (AtLabel "y")),-            ("e2", MvExpression ExThis (ExFormation []))+            ("e2", MvExpression ExThis defaultScope)           ],-          Just (ExApplication (ExApplication (ExFormation []) (BiTau (AtLabel "x") ExGlobal)) (BiTau (AtLabel "y") ExThis), ExFormation [])+          Just (ExApplication (ExApplication (ExFormation []) (BiTau (AtLabel "x") ExGlobal)) (BiTau (AtLabel "y") ExThis), defaultScope)         ),         ( "⟦!a ↦ ∅, !B⟧.!a => (!a >> t, !B >> ⟦ x ↦ ξ.t ⟧ ) => ⟦ t ↦ ∅, x ↦ ξ.t ⟧.t",           ExDispatch (ExFormation [BiVoid (AtMeta "a"), BiMeta "B"]) (AtMeta "a"),@@ -75,7 +75,7 @@                     ]                 )                 (AtLabel "t"),-              ExFormation []+              defaultScope             )         )       ]@@ -84,12 +84,12 @@     it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $       buildExpressions         (ExMeta "e")-        [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation [])),-          substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) (ExFormation []))+        [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope),+          substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) defaultScope)         ]-        `shouldBe` Just [(ExDispatch ExGlobal (AtLabel "x"), ExFormation []), (ExDispatch ExThis (AtLabel "y"), ExFormation [])]+        `shouldBe` Just [(ExDispatch ExGlobal (AtLabel "x"), defaultScope), (ExDispatch ExThis (AtLabel "y"), defaultScope)]     it "!e => [(!e1 >> Q.x)] => X" $       buildExpressions         (ExMeta "e")-        [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation []))]+        [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope)]         `shouldBe` Nothing
test/CLISpec.hs view
@@ -75,7 +75,7 @@     )  testCLIFailed :: [String] -> String -> Expectation-testCLIFailed args output = withStdin "" $ do+testCLIFailed args output = do   (out, result) <- withStdout (try (runCLI args) :: IO (Either ExitCode ()))   out `shouldContain` output   result `shouldBe` Left (ExitFailure 1)@@ -125,14 +125,12 @@         ]      it "fails with negative --max-depth" $-      testCLIFailed-        ["rewrite", "--max-depth=-1"]-        "--max-depth must be positive"+      withStdin "" $+        testCLIFailed ["rewrite", "--max-depth=-1"] "--max-depth must be positive"      it "fails with no rewriting options provided" $-      testCLIFailed-        ["rewrite"]-        "no --rule, no --normalize, no --nothing are provided"+      withStdin "" $+        testCLIFailed ["rewrite"] "no --rule, no --normalize, no --nothing are provided"      it "normalizes from stdin" $       withStdin "Φ ↦ ⟦ a ↦ ⟦ b ↦ ∅ ⟧ (b ↦ [[ ]]) ⟧" $@@ -179,3 +177,12 @@         testCLI           ["rewrite", "--nothing", "--output=xmir", "--omit-listing"]           ["<?xml version=\"1.0\" encoding=\"UTF-8\"?>", "<object", "<listing>4 lines of phi</listing>", "  <o base=\"Q.y\" name=\"x\"/>"]++  describe "dataize" $ do+    it "dataizes simple program" $+      withStdin "Q -> [[ D> 01- ]]" $+        testCLI ["dataize"] ["01-"]++    it "fails to dataize" $+      withStdin "Q -> [[ ]]" $+        testCLIFailed ["dataize"] "[ERROR]: Could not dataize given program"
+ test/DataizeSpec.hs view
@@ -0,0 +1,100 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module DataizeSpec (spec) where++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 Parser (parseProgramThrows)+import Test.Hspec++test :: (Eq a, Show a) => (Expression -> Program -> 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 `shouldBe` output++spec :: Spec+spec = do+  describe "morph" $+    test+      morph+      [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta "00-"], ExGlobal, Just (ExFormation [BiDelta "00-"])),+        ("T => T", ExTermination, ExGlobal, Just ExTermination),+        ("$ => X", ExThis, ExGlobal, Nothing),+        ("Q => X", ExGlobal, ExGlobal, Nothing),+        ( "Q.x (Q -> [[ x -> [[]] ]]) => [[]]",+          ExDispatch ExGlobal (AtLabel "x"),+          ExFormation [BiTau (AtLabel "x") (ExFormation [])],+          Just (ExFormation [])+        )+      ]++  describe "dataize" $+    test+      dataize'+      [ ("[[ D> 00- ]] => 00-", ExFormation [BiDelta "00-"], ExGlobal, Just "00-"),+        ("T => X", ExTermination, ExGlobal, Nothing),+        ( "[[ @ -> [[ D> 00-]] ]] => 00-",+          ExFormation [BiTau AtPhi (ExFormation [BiDelta "00-", BiVoid AtRho]), BiVoid AtRho],+          ExGlobal,+          Just "00-"+        ),+        ( "[[ x -> [[ D> 01- ]] ]].x => 01-",+          ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiDelta "01-", BiVoid AtRho]), BiVoid AtRho]) (AtLabel "x"),+          ExGlobal,+          Just "01-"+        ),+        ( "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]] => 01-",+          ExFormation+            [ BiTau+                AtPhi+                ( ExDispatch+                    ( ExFormation+                        [ BiTau+                            (AtLabel "x")+                            ( ExApplication+                                ( ExFormation+                                    [ BiDelta "01-",+                                      BiVoid (AtLabel "y"),+                                      BiVoid AtRho+                                    ]+                                )+                                (BiTau (AtLabel "y") (ExFormation []))+                            )+                        ]+                    )+                    (AtLabel "x")+                )+            ],+          ExGlobal,+          Just "01-"+        )+      ]++  it "dataizes 5.plus(5)" $ do+    prog <-+      parseProgramThrows+        ( unlines+            [ "Q -> [[",+              "  org -> [[",+              "    eolang -> [[",+              "      bytes -> [[",+              "        data -> ?,",+              "        @ -> $.data",+              "      ]],",+              "      number -> [[",+              "        as-bytes -> ?,",+              "        @ -> $.as-bytes,",+              "        plus -> [[ x -> ?, L> L_org_eolang_number_plus ]]",+              "      ]]",+              "    ]]",+              "  ]],",+              "  @ -> 5.plus(5)",+              "]]"+            ]+        )+    value <- dataize prog+    value `shouldBe` Just "40-24-00-00-00-00-00-00"
test/MatcherSpec.hs view
@@ -48,23 +48,23 @@             [ BiTau (AtLabel "f") (ExFormation [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"))]),               BiTau (AtLabel "t") (ExFormation [BiTau (AtLabel "y") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "y"))])             ],-          ExFormation [],+          defaultScope,           [[("a", MvAttribute (AtLabel "x"))], [("a", MvAttribute (AtLabel "y"))]]         ),         ( "!e => [[x -> Q]] => [(!e >> [[x -> Q]] ), (!e >> Q)]",           ExMeta "e",           ExFormation [BiTau (AtLabel "x") ExGlobal],-          ExFormation [],-          [ [("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]) (ExFormation []))],+          defaultScope,+          [ [("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]) defaultScope)],             [("e", MvExpression ExGlobal (ExFormation [BiTau (AtLabel "x") ExGlobal]))]           ]         ),         ( "!e.!a => Q.org.eolang => [(!e >> Q.org, !a >> eolang), (!e >> Q, !a >> org)]",           ExDispatch (ExMeta "e") (AtMeta "a"),           ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"),-          ExFormation [],-          [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org")) (ExFormation [])), ("a", MvAttribute (AtLabel "eolang"))],-            [("e", MvExpression ExGlobal (ExFormation [])), ("a", MvAttribute (AtLabel "org"))]+          defaultScope,+          [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org")) defaultScope), ("a", MvAttribute (AtLabel "eolang"))],+            [("e", MvExpression ExGlobal defaultScope), ("a", MvAttribute (AtLabel "org"))]           ]         ),         ( "⟦!B1, !a ↦ ∅, !B2⟧.!a => ⟦ x ↦ ξ.t, t ↦ ∅ ⟧.t(ρ ↦ ⟦ x ↦ ξ.t, t ↦ ∅ ⟧) => [(!B1 >> ⟦x ↦ ξ.t⟧, !a >> t, !B2 >> ⟦⟧ )]",@@ -86,7 +86,7 @@                     ]                 )             ),-          ExFormation [],+          defaultScope,           [ [ ("B1", MvBindings [BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t"))]),               ("a", MvAttribute (AtLabel "t")),               ("B2", MvBindings [])@@ -112,85 +112,85 @@       [ ( "[[]] => [[]] => ()",           [],           [],-          ExFormation [],+          defaultScope,           [[]]         ),         ( "[[!B]] => T:[[x -> ?, D> 01-, L> Func]] => (!B >> T)",           [BiMeta "B"],           [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"],-          ExFormation [],+          defaultScope,           [[("B", MvBindings [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"])]]         ),         ( "[[D> 00-]] => [[D> 00-, L> Func]] => []",           [BiDelta "00-"],           [BiDelta "00-", BiLambda "Func"],-          ExFormation [],+          defaultScope,           []         ),         ( "[[y -> ?, !a -> ?]] => [[y -> ?, x -> ?]] => (!a >> x)",           [BiVoid (AtLabel "y"), BiVoid (AtMeta "a")],           [BiVoid (AtLabel "y"), BiVoid (AtLabel "x")],-          ExFormation [],+          defaultScope,           [[("a", MvAttribute (AtLabel "x"))]]         ),         ( "[[!B, x -> ?]] => [[x -> ?]] => (!B >> [[]])",           [BiMeta "B", BiVoid (AtLabel "x")],           [BiVoid (AtLabel "x")],-          ExFormation [],+          defaultScope,           [[("B", MvBindings [])]]         ),         ( "[[!B1, x -> ?, !B2]] => [[x -> ?, y -> ?]] => (!B1 >> [[]], !B2 >> [[y -> ?]])",           [BiMeta "B1", BiVoid (AtLabel "x"), BiMeta "B2"],           [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],-          ExFormation [],+          defaultScope,           [[("B1", MvBindings []), ("B2", MvBindings [BiVoid (AtLabel "y")])]]         ),         ( "[[!B1, !x -> ?, !B2]] => [[y -> ?, D> -> 00-, L> Func]] => (!x >> y, !B1 >> [[]], !B2 >> [[D> -> 00-, L> Func]])",           [BiMeta "B1", BiVoid (AtMeta "x"), BiMeta "B2"],           [BiVoid (AtLabel "y"), BiDelta "00-", BiLambda "Func"],-          ExFormation [],+          defaultScope,           [[("B1", MvBindings []), ("B2", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]]         ),         ( "[[!x -> ?, !y -> ?]] => [[a -> ?, b -> ?]] => (!x >> a, !y >> b)",           [BiVoid (AtMeta "x"), BiVoid (AtMeta "y")],           [BiVoid (AtLabel "a"), BiVoid (AtLabel "b")],-          ExFormation [],+          defaultScope,           [[("x", MvAttribute (AtLabel "a")), ("y", MvAttribute (AtLabel "b"))]]         ),         ( "[[t -> ?, !B]] => [[t -> ?, x -> Q, y -> $]] => (!B >> [[x -> Q, y -> $]])",           [BiVoid (AtLabel "t"), BiMeta "B"],           [BiVoid (AtLabel "t"), BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis],-          ExFormation [],+          defaultScope,           [[("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]]         ),         ( "[[!B, z -> Q]] => [[x -> Q, y -> $, z -> Q]] => (!B >> [[x -> Q, y -> $]])",           [BiMeta "B", BiTau (AtLabel "z") ExGlobal],           [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis, BiTau (AtLabel "z") ExGlobal],-          ExFormation [],+          defaultScope,           [[("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]]         ),         ( "[[L> Func, D> 00-]] => [[D> 00-, L> Func]] => []",           [BiLambda "Func", BiDelta "00-"],           [BiDelta "00-", BiLambda "Func"],-          ExFormation [],+          defaultScope,           []         ),         ( "[[t -> ?, !B]] => [[x -> ?, t -> ?]] => []",           [BiVoid (AtLabel "t"), BiMeta "B"],           [BiVoid (AtLabel "x"), BiVoid (AtLabel "t")],-          ExFormation [],+          defaultScope,           []         ),         ( "[[!B, !a -> ?]] => [[x -> ?, y -> ?]] => (!a >> y, !B >> [[ x -> ? ]] )",           [BiMeta "B", BiVoid (AtMeta "a")],           [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],-          ExFormation [],+          defaultScope,           [[("a", MvAttribute (AtLabel "y")), ("B", MvBindings [BiVoid (AtLabel "x")])]]         ),         ( "[[!B1, !a -> ?, !B2]] => [[ x -> ?, y -> ?, z -> ? ]] => [(), (), ()]",           [BiMeta "B1", BiVoid (AtMeta "a"), BiMeta "B2"],           [BiVoid (AtLabel "x"), BiVoid (AtLabel "y"), BiVoid (AtLabel "z")],-          ExFormation [],+          defaultScope,           [ [ ("B1", MvBindings []),               ("a", MvAttribute (AtLabel "x")),               ("B2", MvBindings [BiVoid (AtLabel "y"), BiVoid (AtLabel "z")])@@ -213,7 +213,7 @@             BiVoid (AtLabel "y"),             BiVoid (AtLabel "z")           ],-          ExFormation [],+          defaultScope,           [ [ ("B1", MvBindings []),               ("a1", MvAttribute (AtLabel "a")),               ("B2", MvBindings []),@@ -281,31 +281,31 @@   describe "matchExpression: expression => pattern => substitution" $     test       matchExpression-      [ ("$ => $ => [()]", ExThis, ExThis, ExFormation [], [[]]),-        ("Q => Q => [()]", ExGlobal, ExGlobal, ExFormation [], [[]]),+      [ ("$ => $ => [()]", ExThis, ExThis, defaultScope, [[]]),+        ("Q => Q => [()]", ExGlobal, ExGlobal, defaultScope, [[]]),         ( "!e => Q => [(!e >> Q)]",           ExMeta "e",           ExGlobal,-          ExFormation [],-          [[("e", MvExpression ExGlobal (ExFormation []))]]+          defaultScope,+          [[("e", MvExpression ExGlobal defaultScope)]]         ),         ( "!e => Q.org(x -> $) => [(!e >> Q.org(x -> $))]",           ExMeta "e",           ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis),-          ExFormation [],-          [[("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis)) (ExFormation []))]]+          defaultScope,+          [[("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis)) defaultScope)]]         ),         ( "!e1.x => Q.org.x => [(!e1 >> Q.org)]",           ExDispatch (ExMeta "e1") (AtLabel "x"),           ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"),-          ExFormation [],-          [[("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")) (ExFormation []))]]+          defaultScope,+          [[("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")) defaultScope)]]         ),         ( "!e.org.!a => $.org.x => [(!e >> $, !a >> x)]",           ExDispatch (ExDispatch (ExMeta "e") (AtLabel "org")) (AtMeta "a"),           ExDispatch (ExDispatch ExThis (AtLabel "org")) (AtLabel "x"),-          ExFormation [],-          [[("e", MvExpression ExThis (ExFormation [])), ("a", MvAttribute (AtLabel "x"))]]+          defaultScope,+          [[("e", MvExpression ExThis defaultScope), ("a", MvAttribute (AtLabel "x"))]]         ),         ( "[[!a -> !e, !B]].!a => [[x -> Q, y -> $]].x => [(!a >> x, !e >> Q, !B >> [y -> $])]",           ExDispatch (ExFormation [BiTau (AtMeta "a") (ExMeta "e"), BiMeta "B"]) (AtMeta "a"),@@ -316,7 +316,7 @@                 ]             )             (AtLabel "x"),-          ExFormation [],+          defaultScope,           [ [ ("a", MvAttribute (AtLabel "x")),               ( "e",                 MvExpression@@ -334,25 +334,25 @@         ( "Q * !t => Q.org => [(!t >> [.org])]",           ExMetaTail ExGlobal "t",           ExDispatch ExGlobal (AtLabel "x"),-          ExFormation [],+          defaultScope,           [[("t", MvTail [TaDispatch (AtLabel "x")])]]         ),         ( "Q * !t => Q.org(x -> [[]]) => [(!t >> [.org, (x -> [[]])])]",           ExMetaTail ExGlobal "t",-          ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") (ExFormation [])),-          ExFormation [],-          [[("t", MvTail [TaDispatch (AtLabel "org"), TaApplication (BiTau (AtLabel "x") (ExFormation []))])]]+          ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") defaultScope),+          defaultScope,+          [[("t", MvTail [TaDispatch (AtLabel "org"), TaApplication (BiTau (AtLabel "x") defaultScope)])]]         ),         ( "Q.!a * !t => Q.org(x -> [[]]) => [(!a >> org, !t >> [(x -> [[]])])]",           ExMetaTail (ExDispatch ExGlobal (AtMeta "a")) "t",-          ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") (ExFormation [])),-          ExFormation [],-          [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication (BiTau (AtLabel "x") (ExFormation []))])]]+          ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") defaultScope),+          defaultScope,+          [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication (BiTau (AtLabel "x") defaultScope)])]]         ),         ( "Q.x(y -> $ * !t1) * !t2 => Q.x(y -> $.q).p => [(!t1 >> [.q], !t2 >> [.p])]",           ExMetaTail (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") (ExMetaTail ExThis "t1"))) "t2",           ExDispatch (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "q")))) (AtLabel "p"),-          ExFormation [],+          defaultScope,           [[("t1", MvTail [TaDispatch (AtLabel "q")]), ("t2", MvTail [TaDispatch (AtLabel "p")])]]         ),         ( "[[!B1, !a ↦ !e1, !B2]](!a ↦ !e2) => ⟦ t ↦ ξ.k, x ↦ ξ.t, k ↦ ∅ ⟧(x ↦ ξ) => [(!B1 >> [[ t -> $.k ]], !a >> x, !B2 >> [[ k -> ? ]], !e1 >> $.t, !e2 >> $)]",@@ -365,7 +365,7 @@                 ]             )             (BiTau (AtLabel "x") ExThis),-          ExFormation [],+          defaultScope,           [ [ ("B1", MvBindings [BiTau (AtLabel "t") (ExDispatch ExThis (AtLabel "k"))]),               ("a", MvAttribute (AtLabel "x")),               ("B2", MvBindings [BiVoid (AtLabel "k")]),@@ -379,7 +379,7 @@                       ]                   )               ),-              ("e2", MvExpression ExThis (ExFormation []))+              ("e2", MvExpression ExThis defaultScope)             ]           ]         )
test/PrettySpec.hs view
@@ -5,7 +5,7 @@  import Ast import Control.Monad (forM_)-import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle)+import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle, defaultScope) import Parser (parseProgramThrows) import Pretty import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe)@@ -62,7 +62,7 @@           map             (\(desc, output, substs) -> (desc, output, substs, SALTY))             [ ("[()]", "[\n  (\n    \n  )\n]", [substEmpty]),-              ("[(!e >> Q.x)]", "[\n  (\n    !e >> Φ.x\n  )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation []))]),+              ("[(!e >> Q.x)]", "[\n  (\n    !e >> Φ.x\n  )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope)]),               ("[(!a >> x)]", "[\n  (\n    !a >> x\n  )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))])             ]     test prettySubsts' useCases
test/RewriterSpec.hs view
@@ -11,17 +11,16 @@ import Control.Monad (forM_, unless) import Data.Aeson import Data.Char (isSpace)-import Data.Foldable (foldlM) import Data.Yaml qualified as Yaml import GHC.Generics import Misc (allPathsIn, ensuredFile) import Parser (parseProgramThrows) import Pretty (prettyProgram)-import Rewriter (rewrite) import System.FilePath (makeRelative, replaceExtension, (</>)) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) import Yaml qualified as Y+import Rewriter (rewrite')  data Rules = Rules   { basic :: Maybe [String],@@ -92,7 +91,7 @@                   if normalize'                     then pure normalizationRules                     else pure []-              rewritten <- foldlM (\prog _ -> rewrite prog rules') program [1 .. repeat']+              rewritten <- rewrite' program program rules' repeat'               result' <- parseProgramThrows (output pack)               unless (rewritten == result') $                 expectationFailure