Add initial support for pre-defined rules

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

@@ -54,6 +54,7 @@ library
     , base >=4.7 && <5
     , directory
     , filepath
+    , mtl
     , yaml
   default-language: Haskell2010
 
@@ -76,6 +77,7 @@ executable normalize-phi
     , directory
     , eo-phi-normalizer
     , filepath
+    , mtl
     , yaml
   default-language: Haskell2010
 
@@ -103,5 +105,6 @@ test-suite eo-phi-normalizer-test
     , filepath
     , hspec
     , hspec-discover
+    , mtl
     , yaml
   default-language: Haskell2010

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

@@ -27,7 +27,7 @@ separator Binding "," ;
 Phi.    Attribute ::= "φ" ;   -- decoratee object
 Rho.    Attribute ::= "ρ" ;   -- parent object
 Sigma.  Attribute ::= "σ" ;   -- home object
-VTX.    Attribute ::= "ν" ;   -- ???
+VTX.    Attribute ::= "ν" ;   -- an object that represents the unique identifier of the containing object
 Label.  Attribute ::= LabelId ;
 Alpha.  Attribute ::= AlphaIndex ;
 

eo-phi-normalizer/package.yaml

@@ -41,6 +41,7 @@ dependencies:
 - directory
 - filepath
 - yaml
+- mtl
 
 ghc-options:
 - -Wall

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

@@ -1,14 +1,23 @@
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecordWildCards #-}
 
-module Language.EO.Phi.Normalize where
+module Language.EO.Phi.Normalize (
+  normalizeObject,
+  normalize,
+  peelObject,
+  unpeelObject,
+) where
 
+import Control.Monad.State
 import Data.Maybe (fromMaybe)
+import Numeric (showHex)
+
+import Control.Monad (forM)
 import Language.EO.Phi.Syntax.Abs
 
 data Context = Context
   { globalObject :: [Binding]
   , thisObject :: [Binding]
+  , totalNuCount :: Int
   }
 
 lookupBinding :: Attribute -> [Binding] -> Maybe Object
@@ -18,27 +27,67 @@ lookupBinding a (AlphaBinding a' object : bindings)
   | otherwise = lookupBinding a bindings
 lookupBinding _ _ = Nothing
 
+isNu :: Binding -> Bool
+isNu (AlphaBinding VTX _) = True
+isNu (EmptyBinding VTX) = True
+isNu _ = False
+
 -- | Normalize an input 𝜑-program.
 normalize :: Program -> Program
-normalize (Program bindings) = Program (map (normalizeBindingWith context) bindings)
+normalize (Program bindings) = evalState (Program . objectBindings <$> normalizeObject (Formation bindings)) context
  where
   context =
     Context
       { globalObject = bindings
       , thisObject = bindings
+      , totalNuCount = nuCount bindings
       }
+  nuCount binds = count isNu binds + sum (map (sum . map (nuCount . objectBindings) . values) binds)
+  count = (length .) . filter
+  values (AlphaBinding _ obj) = [obj]
+  values _ = []
+  objectBindings (Formation bs) = bs
+  objectBindings _ = []
 
-normalizeBindingWith :: Context -> Binding -> Binding
-normalizeBindingWith context = \case
-  AlphaBinding a object -> AlphaBinding a (normalizeObjectWith context object)
-  binding -> binding
+rule1 :: Object -> State Context Object
+rule1 (Formation bindings) = do
+  normalizedBindings <- forM bindings $ \case
+    AlphaBinding a object
+      | a /= VTX ->
+          do
+            object' <- rule1 object
+            pure (AlphaBinding a object')
+    b -> pure b
+  finalBindings <-
+    if not $ any isNu normalizedBindings
+      then do
+        nus <- gets totalNuCount
+        modify (\c -> c{totalNuCount = totalNuCount c + 1})
+        let pad s = (if even (length s) then "" else "0") ++ s
+        let insertDashes s
+              | length s <= 2 = s ++ "-"
+              | otherwise =
+                  let go = \case
+                        [] -> []
+                        [x] -> [x]
+                        [x, y] -> [x, y, '-']
+                        (x : y : xs) -> x : y : '-' : go xs
+                   in go s
+        let dataObject = Formation [DeltaBinding $ Bytes $ insertDashes $ pad $ showHex nus ""]
+        pure (AlphaBinding VTX dataObject : normalizedBindings)
+      else do
+        pure normalizedBindings
+  pure (Formation finalBindings)
+rule1 object = pure object
 
-normalizeObjectWith :: Context -> Object -> Object
-normalizeObjectWith Context{..} object =
+normalizeObject :: Object -> State Context Object
+normalizeObject object = do
+  this <- gets thisObject
   case object of
-    ThisDispatch a ->
-      fromMaybe object (lookupBinding a thisObject)
-    _ -> object
+    -- Rule 1
+    obj@(Formation _) -> rule1 obj
+    ThisDispatch a -> pure $ fromMaybe object (lookupBinding a this)
+    _ -> pure object
 
 -- | Split compound object into its head and applications/dispatch actions.
 peelObject :: Object -> PeeledObject

eo-phi-normalizer/test/Language/EO/PhiSpec.hs

@@ -14,10 +14,10 @@ spec :: Spec
 spec = do
   tests <- runIO (allPhiTests "test/eo/phi/")
   describe "Normalizer" $ do
-    forM_ tests $ \PhiTest{..} -> do
+    forM_ tests $ mapM_ $ \PhiTest{..} -> do
       it name $ do
         Phi.printTree (Phi.normalize input) `shouldBe` Phi.printTree normalized
   describe "Prettify" $ do
-    forM_ tests $ \PhiTest{..} -> do
+    forM_ tests $ mapM_ $ \PhiTest{..} -> do
       it name $ do
         Phi.printTree input `shouldBe` dropWhileEnd isSpace prettified

eo-phi-normalizer/test/Test/EO/Phi.hs

@@ -24,7 +24,7 @@ data PhiTest = PhiTest
   }
   deriving (Generic, FromJSON)
 
-allPhiTests :: FilePath -> IO [PhiTest]
+allPhiTests :: FilePath -> IO [[PhiTest]]
 allPhiTests dir = do
   paths <- listDirectory dir
   forM (sort paths) $ \path ->

eo-phi-normalizer/test/eo/phi/rule-1.yaml

@@ -0,0 +1,15 @@
+- name: 'Program in normal form (1)'
+  input: |
+    {}
+  normalized: |
+    { ν ↦ ⟦ Δ ⤍ 00- ⟧ }
+  prettified: |
+    { }
+
+- name: 'Program in normal form (2)'
+  input: |
+    { φ ↦ ⟦ φ ↦ ⟦ φ ↦ ⟦ ⟧ ⟧ ⟧ }
+  normalized: |
+    { ν ↦ ⟦ Δ ⤍ 03- ⟧, φ ↦ ⟦ ν ↦ ⟦ Δ ⤍ 02- ⟧, φ ↦ ⟦ ν ↦ ⟦ Δ ⤍ 01- ⟧, φ ↦ ⟦ ν ↦ ⟦ Δ ⤍ 00- ⟧ ⟧ ⟧ ⟧ }
+  prettified: |
+    { φ ↦ ⟦ φ ↦ ⟦ φ ↦ ⟦ ⟧ ⟧ ⟧ }

eo-phi-normalizer/test/eo/phi/rule-5.yaml

@@ -0,0 +1,7 @@
+- name: 'Simple static attribute reference'
+  input: |
+    { φ ↦ ⟦ ⟧ , a ↦ ξ.φ }
+  normalized: |
+    { ν ↦ ⟦ Δ ⤍ 01- ⟧, φ ↦ ⟦ ν ↦ ⟦ Δ ⤍ 00- ⟧ ⟧, a ↦ ξ.φ }
+  prettified: |
+    { φ ↦ ⟦ ⟧, a ↦ ξ.φ }