Support custom rewrite rule sets as input

.vscode/settings.json

@@ -1,7 +1,10 @@
 {
-    "haskell.formattingProvider": "fourmolu",
-    "editor.formatOnSave": true,
-    "files.insertFinalNewline": true,
-    "files.trimFinalNewlines": true,
-    "files.trimTrailingWhitespace": true
+  "haskell.formattingProvider": "fourmolu",
+  "[haskell]": {
+    "editor.defaultFormatter": "haskell.haskell"
+  },
+  "editor.formatOnSave": true,
+  "files.insertFinalNewline": true,
+  "files.trimFinalNewlines": true,
+  "files.trimTrailingWhitespace": true
 }

eo-phi-normalizer/Setup.hs

@@ -20,7 +20,7 @@ main = defaultMainWithHooks $ simpleUserHooks
   { hookedPrograms = [ bnfcProgram ]
   , postConf       = \args flags packageDesc localBuildInfo -> do
 #ifndef mingw32_HOST_OS
-      _ <- system "bnfc -d -p Language.EO.Phi --generic -o src/ grammar/EO/Phi/Syntax.cf"
+      _ <- system "bnfc --haskell -d -p Language.EO.Phi --generic -o src/ grammar/EO/Phi/Syntax.cf"
 #endif
       postConf simpleUserHooks args flags packageDesc localBuildInfo
   }

eo-phi-normalizer/app/Main.hs

@@ -1,6 +1,71 @@
-module Main (main) where
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
 
-import Language.EO.Phi
+module Main where
+
+import Control.Monad (when)
+import Data.Foldable (forM_)
+
+import Data.List (nub)
+import Language.EO.Phi (Object (Formation), Program (Program), defaultMain, parseProgram, printTree)
+import Language.EO.Phi.Rules.Common (Context (..), applyRules, applyRulesChain)
+import Language.EO.Phi.Rules.Yaml
+import Options.Generic
+
+data CLINamedParams = CLINamedParams
+  { chain :: Bool
+  , rulesYaml :: Maybe String
+  , outPath :: Maybe String
+  }
+  deriving (Generic, Show, ParseRecord, Read, ParseField)
+
+instance ParseFields CLINamedParams where
+  parseFields _ _ _ _ =
+    CLINamedParams
+      <$> parseFields (Just "Print out steps of reduction") (Just "chain") (Just 'c') Nothing
+      <*> parseFields (Just "Path to the Yaml file with custom rules") (Just "rules-yaml") Nothing Nothing
+      <*> parseFields (Just "Output file path (defaults to stdout)") (Just "output") (Just 'o') Nothing
+
+data CLIOptions = CLIOptions CLINamedParams (Maybe FilePath)
+  deriving (Generic, Show, ParseRecord)
 
 main :: IO ()
-main = defaultMain
+main = do
+  opts <- getRecord "Normalizer"
+  let (CLIOptions params inPath) = opts
+  let (CLINamedParams{..}) = params
+  Control.Monad.when chain (putStrLn "Sorry, --chain is not implemented yet 😅")
+  case rulesYaml of
+    Just path -> do
+      ruleSet <- parseRuleSetFromFile path
+      putStrLn ruleSet.title
+      src <- maybe getContents readFile inPath
+      let progOrError = parseProgram src
+      case progOrError of
+        Left err -> error ("An error occurred parsing the input program: " <> err)
+        Right input@(Program bindings) -> do
+          let results
+                | chain = applyRulesChain (Context (convertRule <$> ruleSet.rules)) (Formation bindings)
+                | otherwise = pure <$> applyRules (Context (convertRule <$> ruleSet.rules)) (Formation bindings)
+              uniqueResults = nub results
+              totalResults = length uniqueResults
+          -- TODO: use outPath to output to file if provided
+          putStrLn "Input:"
+          putStrLn (printTree input)
+          putStrLn "===================================================="
+          forM_ (zip [1 ..] uniqueResults) $ \(i, steps) -> do
+            putStrLn $
+              "Result " <> show i <> " out of " <> show totalResults <> ":"
+            let n = length steps
+            forM_ (zip [1 ..] steps) $ \(k, step) -> do
+              Control.Monad.when chain $ do
+                putStr ("[ " <> show k <> " / " <> show n <> " ]")
+              putStrLn (printTree step)
+            putStrLn "----------------------------------------------------"
+    -- TODO: still need to consider `chain`
+    Nothing -> defaultMain

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

@@ -36,6 +36,7 @@ library
       Language.EO.Phi.Normalize
       Language.EO.Phi.Rules.Common
       Language.EO.Phi.Rules.PhiPaper
+      Language.EO.Phi.Rules.Yaml
       Language.EO.Phi.Syntax
       Language.EO.Phi.Syntax.Abs
       Language.EO.Phi.Syntax.Lex
@@ -45,6 +46,8 @@ library
       Paths_eo_phi_normalizer
   hs-source-dirs:
       src
+  default-extensions:
+      ImportQualifiedPost
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists -Werror
   build-tools:
       alex >=3.2.4
@@ -68,6 +71,8 @@ executable normalize-phi
       Paths_eo_phi_normalizer
   hs-source-dirs:
       app
+  default-extensions:
+      ImportQualifiedPost
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists -Werror -threaded -rtsopts -with-rtsopts=-N
   build-tools:
       alex >=3.2.4
@@ -82,6 +87,7 @@ executable normalize-phi
     , eo-phi-normalizer
     , filepath
     , mtl
+    , optparse-generic
     , string-interpolate
     , yaml
   default-language: Haskell2010
@@ -91,10 +97,14 @@ test-suite eo-phi-normalizer-test
   main-is: Spec.hs
   other-modules:
       Language.EO.PhiSpec
+      Language.EO.YamlSpec
       Test.EO.Phi
+      Test.EO.Yaml
       Paths_eo_phi_normalizer
   hs-source-dirs:
       test
+  default-extensions:
+      ImportQualifiedPost
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists -Werror -threaded -rtsopts -with-rtsopts=-N
   build-tools:
       alex >=3.2.4

eo-phi-normalizer/grammar/EO/Phi/Syntax.cf

@@ -8,6 +8,7 @@ token Bytes ({"--"} | ["0123456789ABCDEF"] ["0123456789ABCDEF"] {"-"} | ["012345
 token Function upper (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
 token LabelId  lower (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
 token AlphaIndex ({"α0"} | {"α"} (digit - ["0"]) (digit)* ) ;
+token MetaId {"!"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
 
 Program. Program ::= "{" [Binding] "}" ;
 
@@ -17,11 +18,13 @@ ObjectDispatch. Object ::= Object "." Attribute ;
 GlobalDispatch. Object ::= "Φ" "." Attribute ;
 ThisDispatch.   Object ::= "ξ" "." Attribute ;
 Termination.    Object ::= "⊥" ;
+MetaObject.     Object ::= MetaId ;
 
 AlphaBinding.   Binding ::= Attribute "↦" Object ;
 EmptyBinding.   Binding ::= Attribute "↦" "∅" ;
 DeltaBinding.   Binding ::= "Δ" "⤍" Bytes ;
 LambdaBinding.  Binding ::= "λ" "⤍" Function ;
+MetaBindings.   Binding ::= MetaId ;
 separator Binding "," ;
 
 Phi.    Attribute ::= "φ" ;   -- decoratee object
@@ -30,6 +33,7 @@ Sigma.  Attribute ::= "σ" ;   -- home object
 VTX.    Attribute ::= "ν" ;   -- the vertex identifier (an object that represents the unique identifier of the containing object)
 Label.  Attribute ::= LabelId ;
 Alpha.  Attribute ::= AlphaIndex ;
+MetaAttr. Attribute ::= MetaId ;
 
 PeeledObject. PeeledObject ::= ObjectHead [ObjectAction] ;
 

eo-phi-normalizer/package.yaml

@@ -44,6 +44,9 @@ dependencies:
 - mtl
 - string-interpolate
 
+default-extensions:
+- ImportQualifiedPost
+
 ghc-options:
 - -Wall
 - -Wcompat
@@ -65,6 +68,9 @@ library:
         - Language.EO.Phi.Syntax.Test
         - Language.EO.Phi.Syntax.ErrM
         - Language.EO.Phi.Syntax.Skel
+        - Language.EO.Phi.Rules.Syntax.Test
+        - Language.EO.Phi.Rules.Syntax.ErrM
+        - Language.EO.Phi.Rules.Syntax.Skel
 
 executables:
   normalize-phi:
@@ -76,6 +82,8 @@ executables:
     - -with-rtsopts=-N
     dependencies:
     - eo-phi-normalizer
+    - optparse-generic
+
 
 tests:
   eo-phi-normalizer-test:

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Language.EO.Phi (
   defaultMain,
   normalize,
@@ -8,8 +11,8 @@ module Language.EO.Phi (
 
 import System.Exit (exitFailure)
 
-import qualified Language.EO.Phi.Syntax.Abs as Phi
-import qualified Language.EO.Phi.Syntax.Par as Phi
+import Language.EO.Phi.Syntax.Abs qualified as Phi
+import Language.EO.Phi.Syntax.Par qualified as Phi
 
 import Language.EO.Phi.Normalize
 import Language.EO.Phi.Syntax

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

@@ -92,6 +92,7 @@ peelObject = \case
   GlobalDispatch attr -> PeeledObject HeadGlobal [ActionDispatch attr]
   ThisDispatch attr -> PeeledObject HeadThis [ActionDispatch attr]
   Termination -> PeeledObject HeadTermination []
+  MetaObject _ -> PeeledObject HeadTermination []
  where
   followedBy (PeeledObject object actions) action = PeeledObject object (actions ++ [action])
 

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

@@ -1,27 +1,51 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Language.EO.Phi.Rules.Common where
 
 import Control.Applicative (Alternative ((<|>)), asum)
+import Data.String (IsString (..))
 import Language.EO.Phi.Syntax.Abs
+import Language.EO.Phi.Syntax.Lex (Token)
+import Language.EO.Phi.Syntax.Par
 
 -- $setup
 -- >>> :set -XOverloadedStrings
 -- >>> import Language.EO.Phi.Syntax
 
+instance IsString Program where fromString = unsafeParseWith pProgram
+instance IsString Object where fromString = unsafeParseWith pObject
+instance IsString Binding where fromString = unsafeParseWith pBinding
+instance IsString Attribute where fromString = unsafeParseWith pAttribute
+instance IsString PeeledObject where fromString = unsafeParseWith pPeeledObject
+instance IsString ObjectHead where fromString = unsafeParseWith pObjectHead
+
+parseWith :: ([Token] -> Either String a) -> String -> Either String a
+parseWith parser input = parser tokens
+ where
+  tokens = myLexer input
+
+-- | Parse a 'Object' from a 'String'.
+-- May throw an 'error` if input has a syntactical or lexical errors.
+unsafeParseWith :: ([Token] -> Either String a) -> String -> a
+unsafeParseWith parser input =
+  case parseWith parser input of
+    Left parseError -> error parseError
+    Right object -> object
+
 data Context = Context
   { allRules :: [Rule]
   }
 
 -- | A rule tries to apply a transformation to the root object, if possible.
-type Rule = Context -> Object -> Maybe Object
+type Rule = Context -> Object -> [Object]
 
 applyOneRuleAtRoot :: Context -> Object -> [Object]
 applyOneRuleAtRoot ctx@Context{..} obj =
   [ obj'
   | rule <- allRules
-  , Just obj' <- [rule ctx obj]
+  , obj' <- rule ctx obj
   ]
 
 withSubObject :: (Object -> [Object]) -> Object -> [Object]
@@ -39,6 +63,7 @@ withSubObject f root =
       GlobalDispatch{} -> []
       ThisDispatch{} -> []
       Termination -> []
+      MetaObject _ -> []
 
 withSubObjectBindings :: (Object -> [Object]) -> [Binding] -> [[Binding]]
 withSubObjectBindings _ [] = []
@@ -54,6 +79,7 @@ withSubObjectBinding f = \case
   EmptyBinding{} -> []
   DeltaBinding{} -> []
   LambdaBinding{} -> []
+  MetaBindings _ -> []
 
 applyOneRule :: Context -> Object -> [Object]
 applyOneRule = withSubObject . applyOneRuleAtRoot

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

@@ -13,8 +13,8 @@ rule1 :: Rule
 rule1 _ = \case
   Formation bindings ->
     let Program bindings' = normalize (Program bindings)
-     in Just (Formation bindings')
-  _ -> Nothing
+     in [Formation bindings']
+  _ -> []
 
 -- | Rule 6.
 rule6 :: Rule
@@ -26,4 +26,4 @@ rule6 ctx (ObjectDispatch (Formation bindings) a)
   bindings' = filter (not . isDispatched) bindings
   isDispatched (AlphaBinding a' _) = a == a'
   isDispatched _ = False
-rule6 _ _ = Nothing
+rule6 _ _ = []