WIP matchObject implementation

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

@@ -35,6 +35,7 @@ library
       Language.EO.Phi
       Language.EO.Phi.Normalize
       Language.EO.Phi.Rules.Common
+      Language.EO.Phi.Rules.PhiPaper
       Language.EO.Phi.Rules.Syntax.Abs
       Language.EO.Phi.Rules.Syntax.Lex
       Language.EO.Phi.Rules.Syntax.Par

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

@@ -15,13 +15,13 @@ data Context = Context
   }
 
 -- | 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]

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 _ _ = []

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

@@ -1,14 +1,18 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveAnyClass #-}
 module Language.EO.Phi.Rules.Yaml where
 
+import Data.Coerce (coerce)
 import GHC.Generics (Generic)
 import Data.Aeson (FromJSON(..))
 import qualified Data.Yaml as Yaml
 import Data.String (IsString(..))
 import qualified Language.EO.Phi.Rules.Syntax.Abs as Rules
 import qualified Language.EO.Phi.Rules.Syntax.Par as Rules
+import qualified Language.EO.Phi.Syntax.Abs as Phi
 
 import qualified Language.EO.Phi.Rules.Common as Common
 
@@ -57,10 +61,10 @@ parseRuleSetFromFile :: FilePath -> IO RuleSet
 parseRuleSetFromFile = Yaml.decodeFileThrow
 
 convertRule :: Rule -> Common.Rule
-convertRule Rule{..} ctx obj =
+convertRule Rule{..} _ctx obj =
   [ obj'
-  | subst <- match pattern obj
-  , let obj' = applySubst subst result
+  | subst <- matchObject pattern obj
+  , Just obj' <- [applySubst subst result]
   ]
 
 -- input: ⟦ a ↦ ⟦ c ↦ ⟦ ⟧ ⟧, b ↦ ⟦ ⟧ ⟧.a
@@ -77,16 +81,127 @@ convertRule Rule{..} ctx obj =
 --  ⟦ c ↦ ⟦ ⟧ ⟧(ρ ↦ ⟦ b ↦ ⟦ ⟧ ⟧)
 
 data Subst = Subst
-  { objectMetas     :: [(MetaId, Phi.Object)]
-  , bindingsMetas   :: [(MetaId, [Phi.Binding])]
-  , attributeMetas  :: [(MetaId, Phi.Attribute)]
+  { objectMetas     :: [(Rules.MetaId, Phi.Object)]
+  , bindingsMetas   :: [(Rules.MetaId, [Phi.Binding])]
+  , attributeMetas  :: [(Rules.MetaId, Phi.Attribute)]
   }
 
+instance Semigroup Subst where
+  (<>) = mergeSubst
+
+instance Monoid Subst where
+  mempty = emptySubst
+
 emptySubst :: Subst
 emptySubst = Subst [] [] []
 
+applySubst :: Subst -> Rules.Object -> Maybe (Phi.Object)
+applySubst subst@Subst{..} = \case
+  Rules.Formation bindings -> do
+    bindings' <- applySubstBindings subst bindings
+    return (Phi.Formation bindings')
+
+  Rules.Application obj bindings -> do
+    obj' <- applySubst subst obj
+    bindings' <- applySubstBindings subst bindings
+    return (Phi.Application obj' bindings')
+
+  Rules.ObjectDispatch obj a -> do
+    obj' <- applySubst subst obj
+    a' <- applySubstAttr subst a
+    return (Phi.ObjectDispatch obj' a')
+
+  Rules.GlobalDispatch a -> do
+    a' <- applySubstAttr subst a
+    return (Phi.GlobalDispatch a')
+
+  Rules.ThisDispatch a -> do
+    a' <- applySubstAttr subst a
+    return (Phi.ThisDispatch a')
+
+  Rules.Termination -> return Phi.Termination
+
+  Rules.MetaObject x -> lookup x objectMetas
+
+applySubstAttr :: Subst -> Rules.Attribute -> Maybe (Phi.Attribute)
+applySubstAttr Subst{..} = \case
+  Rules.Phi     -> return Phi.Phi
+  Rules.Rho     -> return Phi.Rho
+  Rules.Sigma   -> return Phi.Sigma
+  Rules.VTX     -> return Phi.VTX
+  Rules.Label l -> return (Phi.Label (coerce l))
+  Rules.Alpha a -> return (Phi.Alpha (coerce a))
+  Rules.MetaAttr x -> lookup x attributeMetas
+
+applySubstBindings :: Subst -> [Rules.Binding] -> Maybe [Phi.Binding]
+applySubstBindings subst bindings =
+  concat <$> mapM (applySubstBinding subst) bindings
+
+applySubstBinding :: Subst -> Rules.Binding -> Maybe [Phi.Binding]
+applySubstBinding subst@Subst{..} = \case
+  Rules.AlphaBinding a obj -> do
+    a' <- applySubstAttr subst a
+    obj' <- applySubst subst obj
+    return [Phi.AlphaBinding a' obj']
+  Rules.EmptyBinding a -> do
+    a' <- applySubstAttr subst a
+    return [Phi.EmptyBinding a']
+  Rules.DeltaBinding bytes -> return [Phi.DeltaBinding (coerce bytes)]
+  Rules.LambdaBinding bytes -> return [Phi.LambdaBinding (coerce bytes)]
+  Rules.MetaBindings m -> lookup m bindingsMetas
+
 mergeSubst :: Subst -> Subst -> Subst
+mergeSubst (Subst xs ys zs) (Subst xs' ys' zs') =
+  Subst (xs ++ xs') (ys ++ ys') (zs ++ zs')
+
+-- 1. need to implement applySubst' :: Subst -> Rules.Object -> Rules.Object
+-- 2. complete the code
+matchObject :: Rules.Object -> Phi.Object -> [Subst]
+matchObject (Rules.Formation ps) (Phi.Formation bs) =
+  matchBindings ps bs
+matchObject (Rules.Application obj bindings) (Phi.Application obj' bindings') = do
+  subst1 <- matchObject obj obj'
+  subst2 <- matchBindings (applySubstBindings' subst1 bindings) bindings'
+  return (subst1 <> subst2)
+matchObject (Rules.ObjectDispatch pat a) (Phi.ObjectDispatch obj a') = do
+  subst1 <- matchObject pat obj
+  subst2 <- matchAttr (applySubstAttr' subst1 a) a'
+  return (subst1 <> subst2)
+matchObject (Rules.MetaObject m) obj = return Subst
+  { objectMetas = [(m, obj)], bindingsMetas = [], attributeMetas = [] }
+
+matchBindings :: [Rules.Binding] -> [Phi.Binding] -> [Subst]
+matchBindings [] [] = [emptySubst]
+matchBindings [Rules.MetaBindings b] bindings = return Subst
+  { objectMetas = [], bindingsMetas = [(b, bindings)], attributeMetas = [] }
+matchBindings (p:ps) bs = do
+  (bs', subst1) <- matchFindBinding p bs
+  subst2 <- matchBindings ps bs'
+  return (subst1 <> subst2)
+
+-- >>> select [1,2,3,4]
+-- [(1,[2,3,4]),(2,[1,3,4]),(3,[1,2,4]),(4,[1,2,3])]
+select :: [a] -> [(a, [a])]
+select [] = []
+select [x] = [(x, [])]
+select (x:xs) = (x, xs) :
+  [ (y, x:ys)
+  | (y, ys) <- select xs
+  ]
+
+matchFindBinding :: Rules.Binding -> [Phi.Binding] -> [([Phi.Binding], Subst)]
+matchFindBinding p bindings =
+  [ (leftover, subst)
+  | (binding, leftover) <- select bindings
+  , subst <- matchBinding p binding
+  ]
+
+matchBinding :: Rules.Binding -> Phi.Binding -> [Subst]
+matchBinding Rules.MetaBindings{} _ = []
+matchBinding (Rules.AlphaBinding a obj) (Phi.AlphaBinding a' obj') = do
+  subst1 <- matchAttr a a'
+  subst2 <- matchObject obj obj'
+  return (subst1 <> subst2)
 
-match :: Rules.Object -> Phi.Object -> Subst
-match m@MetaId{} obj = Subst { objectMetas = [(m, obj)], bindingsMetas = [], attributeMetas = [] }
-match
+matchAttr :: Rules.Attribute -> Phi.Attribute -> [Subst]
+matchAttr _ _ = []