Merge pull request #105 from objectionary/rule-global-counter

Rule feature: global counter

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

@@ -9,6 +9,7 @@ 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,.|':;!-?][}{)(⟧⟦"])* ;
+token MetaFunctionName {"@"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
 
 Program. Program ::= "{" [Binding] "}" ;
 
@@ -19,6 +20,7 @@ GlobalObject.   Object ::= "Φ";
 ThisObject.     Object ::= "ξ";
 Termination.    Object ::= "⊥" ;
 MetaObject.     Object ::= MetaId ;
+MetaFunction.   Object ::= MetaFunctionName "(" Object ")" ;
 
 AlphaBinding.   Binding ::= Attribute "↦" Object ;
 EmptyBinding.   Binding ::= Attribute "↦" "∅" ;

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

@@ -9,10 +9,9 @@ module Language.EO.Phi.Normalize (
 
 import Control.Monad.State
 import Data.Maybe (fromMaybe)
-import Numeric (showHex)
 
 import Control.Monad (forM)
-import Language.EO.Phi.Rules.Common (lookupBinding)
+import Language.EO.Phi.Rules.Common (intToBytesObject, lookupBinding, nuCount, objectBindings)
 import Language.EO.Phi.Syntax.Abs
 
 data Context = Context
@@ -34,14 +33,8 @@ normalize (Program bindings) = evalState (Program . objectBindings <$> normalize
     Context
       { globalObject = bindings
       , thisObject = bindings
-      , totalNuCount = nuCount bindings
+      , totalNuCount = nuCount (Formation 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 _ = []
 
 rule1 :: Object -> State Context Object
 rule1 (Formation bindings) = do
@@ -57,17 +50,7 @@ rule1 (Formation bindings) = do
       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 ""]
+        let dataObject = intToBytesObject nus
         pure (AlphaBinding VTX dataObject : normalizedBindings)
       else do
         pure normalizedBindings
@@ -93,6 +76,7 @@ peelObject = \case
   ThisObject -> PeeledObject HeadThis []
   Termination -> PeeledObject HeadTermination []
   MetaObject _ -> PeeledObject HeadTermination []
+  MetaFunction _ _ -> error "To be honest, I'm not sure what should be here"
  where
   followedBy (PeeledObject object actions) action = PeeledObject object (actions ++ [action])
 

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

@@ -10,9 +10,11 @@ import Data.String (IsString (..))
 import Language.EO.Phi.Syntax.Abs
 import Language.EO.Phi.Syntax.Lex (Token)
 import Language.EO.Phi.Syntax.Par
+import Numeric (showHex)
 
 -- $setup
 -- >>> :set -XOverloadedStrings
+-- >>> :set -XOverloadedLists
 -- >>> import Language.EO.Phi.Syntax
 
 instance IsString Program where fromString = unsafeParseWith pProgram
@@ -73,6 +75,7 @@ withSubObject f ctx root =
       ThisObject{} -> []
       Termination -> []
       MetaObject _ -> []
+      MetaFunction _ _ -> []
 
 withSubObjectBindings :: (Context -> Object -> [Object]) -> Context -> [Binding] -> [[Binding]]
 withSubObjectBindings _ _ [] = []
@@ -98,8 +101,7 @@ isNF ctx = null . applyOneRule ctx
 
 -- | Apply rules until we get a normal form.
 --
--- >>> mapM_ (putStrLn . Language.EO.Phi.printTree) (applyRules (Context [rule6]) "⟦ a ↦ ⟦ b ↦ ⟦ ⟧ ⟧.b ⟧.a")
--- ⟦ ⟧ (ρ ↦ ⟦ ⟧) (ρ ↦ ⟦ ⟧)
+-- >>> mapM_ (putStrLn . Language.EO.Phi.printTree) (applyRules (Context [rule6] ["⟦ a ↦ ⟦ b ↦ ⟦ ⟧ ⟧.b ⟧"]) "⟦ a ↦ ⟦ b ↦ ⟦ ⟧ ⟧.b ⟧.a")
 applyRules :: Context -> Object -> [Object]
 applyRules ctx obj
   | isNF ctx obj = [obj]
@@ -127,3 +129,36 @@ lookupBinding a (AlphaBinding a' object : bindings)
   | a == a' = Just object
   | otherwise = lookupBinding a bindings
 lookupBinding _ _ = Nothing
+
+objectBindings :: Object -> [Binding]
+objectBindings (Formation bs) = bs
+objectBindings (Application obj bs) = objectBindings obj ++ bs
+objectBindings (ObjectDispatch obj _attr) = objectBindings obj
+objectBindings _ = []
+
+nuCount :: Object -> Int
+nuCount obj = count isNu (objectBindings obj) + sum (map (sum . map nuCount . values) (objectBindings obj))
+ where
+  isNu (AlphaBinding VTX _) = True
+  isNu (EmptyBinding VTX) = True
+  isNu _ = False
+  count = (length .) . filter
+  values (AlphaBinding _ obj') = [obj']
+  values _ = []
+
+intToBytesObject :: Int -> Object
+intToBytesObject n = Formation [DeltaBinding $ Bytes $ insertDashes $ pad $ showHex n ""]
+ where
+  pad s = (if even (length s) then "" else "0") ++ s
+  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
+
+nuCountAsDataObj :: Object -> Object
+nuCountAsDataObj = intToBytesObject . nuCount

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

@@ -86,7 +86,7 @@ convertRule Rule{..} ctx obj =
   , let result' = applySubst contextSubsts result
   , subst <- matchObject pattern' obj
   , all (\cond -> checkCond ctx cond subst) when
-  , obj' <- [applySubst subst result']
+  , obj' <- [applySubst subst (evaluateMetaFuncs result')]
   , not (objectHasMetavars obj')
   ]
 
@@ -108,6 +108,7 @@ objectHasMetavars GlobalObject = False
 objectHasMetavars ThisObject = False
 objectHasMetavars Termination = False
 objectHasMetavars (MetaObject _) = True
+objectHasMetavars (MetaFunction _ _) = True
 
 bindingHasMetavars :: Binding -> Bool
 bindingHasMetavars (AlphaBinding attr obj) = attrHasMetavars attr || objectHasMetavars obj
@@ -243,6 +244,17 @@ matchObject (MetaObject m) obj =
 matchObject Termination Termination = [emptySubst]
 matchObject _ _ = [] -- ? emptySubst ?
 
+evaluateMetaFuncs :: Object -> Object
+evaluateMetaFuncs (MetaFunction (MetaFunctionName "@T") obj) = Common.nuCountAsDataObj obj
+evaluateMetaFuncs (Formation bindings) = Formation (map evaluateMetaFuncsBinding bindings)
+evaluateMetaFuncs (Application obj bindings) = Application (evaluateMetaFuncs obj) (map evaluateMetaFuncsBinding bindings)
+evaluateMetaFuncs (ObjectDispatch obj a) = ObjectDispatch (evaluateMetaFuncs obj) a
+evaluateMetaFuncs obj = obj
+
+evaluateMetaFuncsBinding :: Binding -> Binding
+evaluateMetaFuncsBinding (AlphaBinding attr obj) = AlphaBinding attr (evaluateMetaFuncs obj)
+evaluateMetaFuncsBinding binding = binding
+
 matchBindings :: [Binding] -> [Binding] -> [Subst]
 matchBindings [] [] = [emptySubst]
 matchBindings [MetaBindings b] bindings =