650 fix new.yaml

.github/workflows/ghc.yml

@@ -84,6 +84,7 @@ jobs:
             **/*.sh
             **/*.cf
           ignore: >-
+            eo/**/*
             **/.pre-commit-config.yaml
             **/run-fourmolu.sh
             **/Abs.hs

eo-phi-normalizer/app/Main.hs

@@ -81,9 +81,8 @@ import Language.EO.Phi.Report.Data (makeProgramReport, makeReport)
 import Language.EO.Phi.Report.Html (reportCSS, reportJS, toStringReport)
 import Language.EO.Phi.Rules.Common (ApplicationLimits (ApplicationLimits), Context (..), LogEntry (..), applyRulesChainWith', applyRulesWith, objectSize)
 import Language.EO.Phi.Rules.Fast (fastYegorInsideOut, fastYegorInsideOutAsRule)
-import Language.EO.Phi.Rules.RunYegor (yegorRuleSet)
 import Language.EO.Phi.Rules.Yaml (RuleSet (rules, title), convertRuleNamed, parseRuleSetFromFile)
-import Language.EO.Phi.Syntax (SugarableFinally, desugar, errorExpectedDesugaredObject, printTreeDontSugar, wrapBytesInBytes, wrapTermination)
+import Language.EO.Phi.Syntax (SugarableFinally, desugar, errorExpectedDesugaredObject, printTreeNoSugar, wrapBytesInBytes, wrapTermination)
 import Language.EO.Phi.ToLaTeX
 import Language.EO.Test.YamlSpec (spec)
 import Options.Applicative hiding (metavar)
@@ -584,7 +583,7 @@ wrapRawBytesIn = \case
   obj@ConstFloatRaw{} -> errorExpectedDesugaredObject obj
 
 printSugarable :: (Pretty a, SugarableFinally a) => Bool -> a -> String
-printSugarable noSugar = if noSugar then printTreeDontSugar else printTree
+printSugarable noSugar = if noSugar then printTreeNoSugar else printTree
 
 printAsProgramOrAsObject :: Bool -> Object -> String
 printAsProgramOrAsObject noSugar = \case
@@ -604,7 +603,7 @@ main = withCorrectLocale do
       logStrLn $ encodeToJSONString metrics
     CLI'PrintRules' CLI'PrintRules{..} -> do
       (logStrLn, _) <- getLoggers Nothing
-      rules <- rules <$> maybe (return yegorRuleSet) parseRuleSetFromFile rulesPath
+      rules <- rules <$> maybe (decodeThrow $(embedFileRelative "test/eo/phi/rules/new.yaml")) parseRuleSetFromFile rulesPath
       let toLatex' = if compact then rulesToLatexCompact else toLatex
       logStrLn $ show $ toLatex' rules
     CLI'RewritePhi' CLI'RewritePhi{..} -> do

eo-phi-normalizer/eo-phi-normalizer.cabal

@@ -398,7 +398,6 @@ extra-source-files:
     test/eo/phi/rewriting.yaml
     test/eo/phi/rules/new.yaml
     test/eo/phi/rules/streams.yaml
-    test/eo/phi/rules/yegor.yaml
 
 source-repository head
   type: git
@@ -436,7 +435,6 @@ library
       Language.EO.Phi.Report.Html
       Language.EO.Phi.Rules.Common
       Language.EO.Phi.Rules.Fast
-      Language.EO.Phi.Rules.RunYegor
       Language.EO.Phi.Rules.Yaml
       Language.EO.Phi.Syntax
       Language.EO.Phi.Syntax.Abs
@@ -568,7 +566,6 @@ test-suite doctests
       Language.EO.Phi.Report.Html
       Language.EO.Phi.Rules.Common
       Language.EO.Phi.Rules.Fast
-      Language.EO.Phi.Rules.RunYegor
       Language.EO.Phi.Rules.Yaml
       Language.EO.Phi.Syntax
       Language.EO.Phi.Syntax.Abs

eo-phi-normalizer/src/Language/EO/Phi/Metrics/Collect.hs

@@ -162,7 +162,7 @@ getThisObjectMetrics obj = execState (inspect obj) mempty
 --
 -- If no object is accessible by the path, return the path that led to a non-formation.
 -- >>> flip getObjectByPath ["org", "eolang"] "⟦ org ↦ ⟦ eolang ↦ ⟦ x ↦ ⟦ φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, z ↦ ⟦ y ↦ ⟦ x ↦ ∅, φ ↦ ξ.x ⟧, φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧⟧"
--- Right (Formation [AlphaBinding (AttributeNoSugar (Label (LabelId "x"))) (Formation [AlphaBinding (AttributeNoSugar Phi) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (AttributeNoSugar (Alpha (AlphaIndex "\945\&0"))) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),AlphaBinding (AttributeNoSugar (Label (LabelId "z"))) (Formation [AlphaBinding (AttributeNoSugar (Label (LabelId "y"))) (Formation [EmptyBinding (Label (LabelId "x")),AlphaBinding (AttributeNoSugar Phi) (ObjectDispatch ThisObject (Label (LabelId "x")))]),AlphaBinding (AttributeNoSugar Phi) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (AttributeNoSugar (Alpha (AlphaIndex "\945\&0"))) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),LambdaBinding (Function "Package")])
+-- Right (Formation [AlphaBinding (AttributeNoSugar (Label (LabelId "x"))) (Formation [AlphaBinding (AttributeNoSugar Phi) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (AttributeNoSugar (Alpha (AlphaIndex "\945\&0"))) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])]),EmptyBinding Rho]),AlphaBinding (AttributeNoSugar (Label (LabelId "z"))) (Formation [AlphaBinding (AttributeNoSugar (Label (LabelId "y"))) (Formation [EmptyBinding (Label (LabelId "x")),AlphaBinding (AttributeNoSugar Phi) (ObjectDispatch ThisObject (Label (LabelId "x"))),EmptyBinding Rho]),AlphaBinding (AttributeNoSugar Phi) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (AttributeNoSugar (Alpha (AlphaIndex "\945\&0"))) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])]),EmptyBinding Rho]),LambdaBinding (Function "Package"),EmptyBinding Rho])
 --
 -- >>> flip getObjectByPath ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧"
 -- Left ["a"]

eo-phi-normalizer/src/Language/EO/Phi/Preprocess.hs

@@ -129,9 +129,3 @@ preprocess' sep = concat . addPrefix sep
 
 preprocess :: String -> String
 preprocess = preprocess' parseAlphaBindingSugar
-
-input1 :: String
-input1 = "{⟦ org ↦ ⟦ ⟧(α0 ↦ !b1) ⟧}"
-
--- >>> preprocess input1
--- "{\10214 #org \8614 \10214 \10215(#\945\&0 \8614 !b1) \10215}"

eo-phi-normalizer/src/Language/EO/Phi/Rules/Common.hs

@@ -53,6 +53,7 @@ import Language.EO.Phi.Syntax (
   desugar,
   errorExpectedDesugaredBinding,
   errorExpectedDesugaredObject,
+  isRhoBinding,
   printTree,
   pattern AlphaBinding',
   pattern AlphaBinding'',
@@ -173,7 +174,7 @@ withSubObjectBindings f ctx (b : bs) =
 withSubObjectBinding :: (Context -> Object -> [(String, Object)]) -> Context -> Binding -> [(String, Binding)]
 withSubObjectBinding f ctx = \case
   AlphaBinding' a obj -> propagateName1 (AlphaBinding' a) <$> withSubObject f (ctx{currentAttr = a}) obj
-  b@AlphaBinding{} -> errorExpectedDesugaredBinding b
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   b@AlphaBindingSugar{} -> errorExpectedDesugaredBinding b
   EmptyBinding{} -> []
   DeltaBinding{} -> []
@@ -232,7 +233,8 @@ objectSize = \case
 
 bindingSize :: Binding -> Int
 bindingSize = \case
-  AlphaBinding _attr obj -> objectSize obj
+  AlphaBinding' _attr obj -> objectSize obj
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   EmptyBinding _attr -> 1
   DeltaBinding _bytes -> 1
   DeltaEmptyBinding -> 1
@@ -426,10 +428,6 @@ objectBindings (Application obj bs) = objectBindings obj ++ bs
 objectBindings (ObjectDispatch obj _attr) = objectBindings obj
 objectBindings _ = []
 
-isRhoBinding :: Binding -> Bool
-isRhoBinding (AlphaBinding' Rho _) = True
-isRhoBinding _ = False
-
 hideRhoInBinding :: Binding -> Binding
 hideRhoInBinding = \case
   AlphaBinding a obj -> AlphaBinding a (hideRho obj)

eo-phi-normalizer/src/Language/EO/Phi/Rules/Yaml.hs

@@ -23,13 +23,16 @@
 {- FOURMOLU_ENABLE -}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-forall-identifier #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -61,6 +64,7 @@
 -- >>> :set -XOverloadedStrings
 -- >>> :set -XOverloadedLists
 
+instance FromJSON Program where parseJSON = fmap fromString . parseJSON
 instance FromJSON Object where parseJSON = fmap fromString . parseJSON
 instance FromJSON Binding where parseJSON = fmap fromString . parseJSON
 
@@ -79,6 +83,11 @@
 instance FromJSON LabelId
 instance FromJSON AlphaIndex
 
+deriving newtype instance FromJSON Bytes
+
+instance FromJSON (NoDesugar Program) where parseJSON = fmap fromString . parseJSON
+instance FromJSON (NoDesugar Object) where parseJSON = fmap fromString . parseJSON
+
 data RuleSet = RuleSet
   { title :: String
   , rules :: [Rule]
@@ -96,9 +105,9 @@
   { name :: String
   , description :: String
   , context :: Maybe RuleContext
   , forall :: Maybe [MetaId]
-  , pattern :: Object
-  , result :: Object
+  , pattern :: NoDesugar Object
+  , result :: NoDesugar Object
   , fresh :: Maybe [FreshMetaId]
   , when :: Maybe [Condition]
   , tests :: Maybe [RuleTest]
@@ -122,6 +131,7 @@
 newtype RuleTestOption = TakeOne {take_one :: Bool}
   -- deriving (Generic, Show, FromJSON)
   deriving (Eq, Generic, Show)
+
 instance FromJSON RuleTestOption where
   parseJSON = genericParseJSON defaultOptions{sumEncoding = UntaggedValue}
 
@@ -130,6 +140,7 @@
   , bindings :: [Binding]
   }
   deriving (Generic, Show, FromJSON)
+
 data Condition
   = IsNF {nf :: Object}
   | IsNFInsideFormation {nf_inside_formation :: Object}
@@ -139,6 +150,7 @@
   | ApplyInSubformations {apply_in_subformations :: Bool}
   | ApplyInAbstractSubformations {apply_in_abstract_subformations :: Bool}
   deriving (Generic, Show)
+
 instance FromJSON Condition where
   parseJSON = genericParseJSON defaultOptions{sumEncoding = UntaggedValue}
 
@@ -153,8 +165,8 @@
         Set.mapMonotonic MetaIdLabel $
           foldMap (Set.fromList . map (\FreshMetaId{name = x} -> x)) fresh
 
-      patternMetaIds = objectMetaIds pattern
-      resultMetaIds = objectMetaIds result
+      patternMetaIds = objectMetaIds pattern.noDesugar
+      resultMetaIds = objectMetaIds result.noDesugar
 
       unusedFreshMetaIds = Set.difference freshMetaIds resultMetaIds
 
@@ -179,8 +191,8 @@
         error ("invalid rule: result uses meta variables not quantified by the forall or the fresh: " <> ppMetaIds unquantifiedResultMetaIds)
 
   contextSubsts <- matchContext ctx context
-  let pattern' = applySubst contextSubsts pattern
-      result' = applySubst contextSubsts result
+  let pattern' = applySubst contextSubsts pattern.noDesugar
+      result' = applySubst contextSubsts result.noDesugar
   subst <- matchObject pattern' obj
   guard $ all (\cond -> checkCond ctx cond (contextSubsts <> subst)) (fromMaybe [] when)
   let substFresh = mkFreshSubst ctx result' fresh
@@ -249,7 +261,7 @@
 bindingLabelIds :: Binding -> Set LabelId
 bindingLabelIds = \case
   AlphaBinding' a obj -> objectLabelIds obj <> attrLabelIds a
-  b@AlphaBinding{} -> errorExpectedDesugaredBinding b
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   DeltaBinding _bytes -> mempty
   EmptyBinding a -> attrLabelIds a
   DeltaEmptyBinding -> mempty
@@ -301,7 +313,7 @@
 
 bindingMetaIds :: Binding -> Set MetaId
 bindingMetaIds (AlphaBinding' attr obj) = attrMetaIds attr <> objectMetaIds obj
-bindingMetaIds b@AlphaBinding{} = errorExpectedDesugaredBinding b
+bindingMetaIds b@AlphaBinding''{} = errorExpectedDesugaredBinding b
 bindingMetaIds (EmptyBinding attr) = attrMetaIds attr
 bindingMetaIds (DeltaBinding _) = mempty
 bindingMetaIds DeltaEmptyBinding = mempty
@@ -419,6 +431,7 @@
   , bytesMetas :: [(BytesMetaId, Bytes)]
   , contextMetas :: [(TailMetaId, OneHoleContext)]
   }
+
 instance Show Subst where
   show Subst{..} =
     intercalate
@@ -486,7 +499,7 @@
 applySubstBinding subst@Subst{..} = \case
   AlphaBinding' a obj ->
     [AlphaBinding' (applySubstAttr subst a) (applySubst subst obj)]
-  b@AlphaBinding{} -> errorExpectedDesugaredBinding b
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   EmptyBinding a ->
     [EmptyBinding (applySubstAttr subst a)]
   DeltaBinding bytes -> [DeltaBinding (coerce bytes)]
@@ -674,6 +687,7 @@
 substThisBinding :: Object -> Binding -> Binding
 substThisBinding obj = \case
   AlphaBinding a obj' -> AlphaBinding a (substThis obj obj')
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   EmptyBinding a -> EmptyBinding a
   DeltaBinding bytes -> DeltaBinding bytes
   DeltaEmptyBinding -> DeltaEmptyBinding
@@ -682,15 +696,26 @@
   b@MetaDeltaBinding{} -> error ("impossible: trying to substitute ξ in " <> printTree b)
   b@AlphaBindingSugar{} -> errorExpectedDesugaredBinding b
 
-contextualize :: Object -> Object -> Object
+contextualize ::
+  -- | current object
+  Object ->
+  -- | expression
+  Object ->
+  Object
 contextualize thisObj = go
  where
   go = \case
-    ThisObject -> thisObj -- ξ is substituted
+    -- C1
+    -- TODO #651:10m Currently, causes infinite recursion. Create an issue. Maybe need to add functionality to the rules to check that contextualization result can be rewritten to a normal form.
+    GlobalObject -> GlobalObject
+    -- C2
+    ThisObject -> thisObj
+    -- C3
     obj@(Formation _bindings) -> obj
+    -- C4
     ObjectDispatch obj a -> ObjectDispatch (go obj) a
+    -- C5
     Application obj bindings -> Application (go obj) (map (contextualizeBinding thisObj) bindings)
-    GlobalObject -> GlobalObject -- TODO: Change to what GlobalObject is attached to
     obj@GlobalObjectPhiOrg -> errorExpectedDesugaredObject obj
     Termination -> Termination
     obj@MetaTailContext{} -> error ("impossible: trying to contextualize " <> printTree obj)
@@ -708,6 +733,7 @@
 contextualizeBinding :: Object -> Binding -> Binding
 contextualizeBinding obj = \case
   AlphaBinding a obj' -> AlphaBinding a (contextualize obj obj')
+  b@AlphaBinding''{} -> errorExpectedDesugaredBinding b
   EmptyBinding a -> EmptyBinding a
   DeltaBinding bytes -> DeltaBinding bytes
   DeltaEmptyBinding -> DeltaEmptyBinding