-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

-- The goal of the module is to traverse given Ast and build substitutions
-- from meta variables to appropriate meta values
module Matcher where

import Ast
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)

-- Meta value
-- The right part of substitution
data MetaValue
  = MvAttribute Attribute -- !a
  | MvBytes String -- !b
  | MvBindings [Binding] -- !B
  | MvFunction String -- !F
  | MvExpression Expression -- !e
  | MvTail [Tail] -- !t
  deriving (MetaValue -> MetaValue -> Bool
(MetaValue -> MetaValue -> Bool)
-> (MetaValue -> MetaValue -> Bool) -> Eq MetaValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetaValue -> MetaValue -> Bool
== :: MetaValue -> MetaValue -> Bool
$c/= :: MetaValue -> MetaValue -> Bool
/= :: MetaValue -> MetaValue -> Bool
Eq, Int -> MetaValue -> ShowS
[MetaValue] -> ShowS
MetaValue -> String
(Int -> MetaValue -> ShowS)
-> (MetaValue -> String)
-> ([MetaValue] -> ShowS)
-> Show MetaValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetaValue -> ShowS
showsPrec :: Int -> MetaValue -> ShowS
$cshow :: MetaValue -> String
show :: MetaValue -> String
$cshowList :: [MetaValue] -> ShowS
showList :: [MetaValue] -> ShowS
Show)

-- Tail operation after expression
-- Dispatch or application
data Tail
  = TaApplication Binding -- BiTau only
  | TaDispatch Attribute
  deriving (Tail -> Tail -> Bool
(Tail -> Tail -> Bool) -> (Tail -> Tail -> Bool) -> Eq Tail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tail -> Tail -> Bool
== :: Tail -> Tail -> Bool
$c/= :: Tail -> Tail -> Bool
/= :: Tail -> Tail -> Bool
Eq, Int -> Tail -> ShowS
[Tail] -> ShowS
Tail -> String
(Int -> Tail -> ShowS)
-> (Tail -> String) -> ([Tail] -> ShowS) -> Show Tail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tail -> ShowS
showsPrec :: Int -> Tail -> ShowS
$cshow :: Tail -> String
show :: Tail -> String
$cshowList :: [Tail] -> ShowS
showList :: [Tail] -> ShowS
Show)

-- Substitution
-- Shows the match of meta name to meta value
newtype Subst = Subst (Map String MetaValue)
  deriving (Subst -> Subst -> Bool
(Subst -> Subst -> Bool) -> (Subst -> Subst -> Bool) -> Eq Subst
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Subst -> Subst -> Bool
== :: Subst -> Subst -> Bool
$c/= :: Subst -> Subst -> Bool
/= :: Subst -> Subst -> Bool
Eq, Int -> Subst -> ShowS
[Subst] -> ShowS
Subst -> String
(Int -> Subst -> ShowS)
-> (Subst -> String) -> ([Subst] -> ShowS) -> Show Subst
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Subst -> ShowS
showsPrec :: Int -> Subst -> ShowS
$cshow :: Subst -> String
show :: Subst -> String
$cshowList :: [Subst] -> ShowS
showList :: [Subst] -> ShowS
Show)

-- Empty substitution
substEmpty :: Subst
substEmpty :: Subst
substEmpty = Map String MetaValue -> Subst
Subst Map String MetaValue
forall k a. Map k a
Map.empty

-- Singleton substitution with one (key -> value) pair
substSingle :: String -> MetaValue -> Subst
substSingle :: String -> MetaValue -> Subst
substSingle String
key MetaValue
value = Map String MetaValue -> Subst
Subst (String -> MetaValue -> Map String MetaValue
forall k a. k -> a -> Map k a
Map.singleton String
key MetaValue
value)

-- Combine two substitutions into a single one
-- Fails if values by the same keys are not equal
combine :: Subst -> Subst -> Maybe Subst
combine :: Subst -> Subst -> Maybe Subst
combine (Subst Map String MetaValue
a) (Subst Map String MetaValue
b) = [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst
combine' (Map String MetaValue -> [(String, MetaValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String MetaValue
b) Map String MetaValue
a
  where
    combine' :: [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst
    combine' :: [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst
combine' [] Map String MetaValue
acc = Subst -> Maybe Subst
forall a. a -> Maybe a
Just (Map String MetaValue -> Subst
Subst Map String MetaValue
acc)
    combine' ((String
key, MetaValue
value) : [(String, MetaValue)]
rest) Map String MetaValue
acc = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String MetaValue
acc of
      Just MetaValue
found
        | MetaValue
found MetaValue -> MetaValue -> Bool
forall a. Eq a => a -> a -> Bool
== MetaValue
value -> [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst
combine' [(String, MetaValue)]
rest Map String MetaValue
acc
        | Bool
otherwise -> Maybe Subst
forall a. Maybe a
Nothing
      Maybe MetaValue
Nothing -> [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst
combine' [(String, MetaValue)]
rest (String -> MetaValue -> Map String MetaValue -> Map String MetaValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
key MetaValue
value Map String MetaValue
acc)

combineMany :: [Subst] -> [Subst] -> [Subst]
combineMany :: [Subst] -> [Subst] -> [Subst]
combineMany [Subst]
xs [Subst]
xy = [Maybe Subst] -> [Subst]
forall a. [Maybe a] -> [a]
catMaybes [Subst -> Subst -> Maybe Subst
combine Subst
x Subst
y | Subst
x <- [Subst]
xs, Subst
y <- [Subst]
xy]

matchAttribute :: Attribute -> Attribute -> [Subst]
matchAttribute :: Attribute -> Attribute -> [Subst]
matchAttribute (AtMeta String
meta) Attribute
tgt = [String -> MetaValue -> Subst
substSingle String
meta (Attribute -> MetaValue
MvAttribute Attribute
tgt)]
matchAttribute Attribute
ptn Attribute
tgt
  | Attribute
ptn Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
tgt = [Subst
substEmpty]
  | Bool
otherwise = []

matchBinding :: Binding -> Binding -> [Subst]
matchBinding :: Binding -> Binding -> [Subst]
matchBinding (BiVoid Attribute
pattr) (BiVoid Attribute
tattr) = Attribute -> Attribute -> [Subst]
matchAttribute Attribute
pattr Attribute
tattr
matchBinding (BiDelta String
pbts) (BiDelta String
tbts)
  | String
pbts String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
tbts = [Subst
substEmpty]
  | Bool
otherwise = []
matchBinding (BiMetaDelta String
meta) (BiDelta String
tBts) = [String -> MetaValue -> Subst
substSingle String
meta (String -> MetaValue
MvBytes String
tBts)]
matchBinding (BiLambda String
pFunc) (BiLambda String
tFunc)
  | String
pFunc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
tFunc = [Subst
substEmpty]
  | Bool
otherwise = []
matchBinding (BiMetaLambda String
meta) (BiLambda String
tFunc) = [String -> MetaValue -> Subst
substSingle String
meta (String -> MetaValue
MvFunction String
tFunc)]
matchBinding (BiTau Attribute
pattr Expression
pexp) (BiTau Attribute
tattr Expression
texp) = [Subst] -> [Subst] -> [Subst]
combineMany (Attribute -> Attribute -> [Subst]
matchAttribute Attribute
pattr Attribute
tattr) (Expression -> Expression -> [Subst]
matchExpression Expression
pexp Expression
texp)
matchBinding Binding
_ Binding
_ = []

-- Match bindings with ordering
matchBindings :: [Binding] -> [Binding] -> [Subst]
matchBindings :: [Binding] -> [Binding] -> [Subst]
matchBindings [] [] = [Subst
substEmpty]
matchBindings [] [Binding]
_ = []
matchBindings ((BiMeta String
name) : [Binding]
pbs) [Binding]
tbs = do
  let splits :: [([Binding], [Binding])]
splits = [Int -> [Binding] -> ([Binding], [Binding])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [Binding]
tbs | Int
idx <- [Int
0 .. [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
tbs]]
  [Maybe Subst] -> [Subst]
forall a. [Maybe a] -> [a]
catMaybes
    [ Subst -> Subst -> Maybe Subst
combine (String -> MetaValue -> Subst
substSingle String
name ([Binding] -> MetaValue
MvBindings [Binding]
before)) Subst
subst
      | ([Binding]
before, [Binding]
after) <- [([Binding], [Binding])]
splits,
        Subst
subst <- [Binding] -> [Binding] -> [Subst]
matchBindings [Binding]
pbs [Binding]
after
    ]
matchBindings (Binding
pb : [Binding]
pbs) (Binding
tb : [Binding]
tbs) = [Subst] -> [Subst] -> [Subst]
combineMany (Binding -> Binding -> [Subst]
matchBinding Binding
pb Binding
tb) ([Binding] -> [Binding] -> [Subst]
matchBindings [Binding]
pbs [Binding]
tbs)
matchBindings [Binding]
_ [Binding]
_ = []

-- Recursively go through given target expression and try to find
-- the head expression which matches to given pattern.
-- If there's one - build the list of all the tail operations after head expression.
-- The tail operations may be only dispatches or applications
tailExpressions :: Expression -> Expression -> ([Subst], [Tail])
tailExpressions :: Expression -> Expression -> ([Subst], [Tail])
tailExpressions Expression
ptn Expression
tgt = do
  let ([Subst]
substs, [Tail]
tails) = Expression -> Expression -> ([Subst], [Tail])
tailExpressionsReversed Expression
ptn Expression
tgt
  ([Subst]
substs, [Tail] -> [Tail]
forall a. [a] -> [a]
reverse [Tail]
tails)
  where
    tailExpressionsReversed :: Expression -> Expression -> ([Subst], [Tail])
    tailExpressionsReversed :: Expression -> Expression -> ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
tgt' = case Expression -> Expression -> [Subst]
matchExpression Expression
ptn' Expression
tgt' of
      [] -> case Expression
tgt' of
        ExDispatch Expression
expr Attribute
attr -> do
          let ([Subst]
substs, [Tail]
tails) = Expression -> Expression -> ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
expr
          ([Subst]
substs, Attribute -> Tail
TaDispatch Attribute
attr Tail -> [Tail] -> [Tail]
forall a. a -> [a] -> [a]
: [Tail]
tails)
        ExApplication Expression
expr Binding
tau -> do
          let ([Subst]
substs, [Tail]
tails) = Expression -> Expression -> ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
expr
          ([Subst]
substs, Binding -> Tail
TaApplication Binding
tau Tail -> [Tail] -> [Tail]
forall a. a -> [a] -> [a]
: [Tail]
tails)
        Expression
_ -> ([], [])
      [Subst]
substs -> ([Subst]
substs, [])

matchExpression :: Expression -> Expression -> [Subst]
matchExpression :: Expression -> Expression -> [Subst]
matchExpression (ExMeta String
meta) Expression
tgt = [String -> MetaValue -> Subst
substSingle String
meta (Expression -> MetaValue
MvExpression Expression
tgt)]
matchExpression Expression
ExThis Expression
ExThis = [Subst
substEmpty]
matchExpression Expression
ExGlobal Expression
ExGlobal = [Subst
substEmpty]
matchExpression Expression
ExTermination Expression
ExTermination = [Subst
substEmpty]
matchExpression (ExFormation [Binding]
pbs) (ExFormation [Binding]
tbs) = [Binding] -> [Binding] -> [Subst]
matchBindings [Binding]
pbs [Binding]
tbs
matchExpression (ExDispatch Expression
pexp Attribute
pattr) (ExDispatch Expression
texp Attribute
tattr) = [Subst] -> [Subst] -> [Subst]
combineMany (Attribute -> Attribute -> [Subst]
matchAttribute Attribute
pattr Attribute
tattr) (Expression -> Expression -> [Subst]
matchExpression Expression
pexp Expression
texp)
matchExpression (ExApplication Expression
pexp Binding
pbd) (ExApplication Expression
texp Binding
tbd) = [Subst] -> [Subst] -> [Subst]
combineMany (Expression -> Expression -> [Subst]
matchExpression Expression
pexp Expression
texp) (Binding -> Binding -> [Subst]
matchBinding Binding
pbd Binding
tbd)
matchExpression (ExMetaTail Expression
exp String
meta) Expression
tgt = case Expression -> Expression -> ([Subst], [Tail])
tailExpressions Expression
exp Expression
tgt of
  ([], [Tail]
_) -> []
  ([Subst]
substs, [Tail]
tails) -> [Subst] -> [Subst] -> [Subst]
combineMany [Subst]
substs [String -> MetaValue -> Subst
substSingle String
meta ([Tail] -> MetaValue
MvTail [Tail]
tails)]
matchExpression Expression
_ Expression
_ = []

-- Deep match pattern to expression inside binding
matchBindingExpression :: Binding -> Expression -> [Subst]
matchBindingExpression :: Binding -> Expression -> [Subst]
matchBindingExpression (BiTau Attribute
_ Expression
texp) Expression
ptn = Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
texp
matchBindingExpression Binding
_ Expression
_ = []

-- Match expression with deep nested expression(s) matching
matchExpressionDeep :: Expression -> Expression -> [Subst]
matchExpressionDeep :: Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
tgt = do
  let matched :: [Subst]
matched = Expression -> Expression -> [Subst]
matchExpression Expression
ptn Expression
tgt
      deep :: [Subst]
deep = case Expression
tgt of
        ExFormation [Binding]
bds -> (Binding -> [Subst]) -> [Binding] -> [Subst]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Binding -> Expression -> [Subst]
`matchBindingExpression` Expression
ptn) [Binding]
bds
        ExDispatch Expression
exp Attribute
_ -> Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp
        ExApplication Expression
exp Binding
tau -> Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp [Subst] -> [Subst] -> [Subst]
forall a. [a] -> [a] -> [a]
++ Binding -> Expression -> [Subst]
matchBindingExpression Binding
tau Expression
ptn
        Expression
_ -> []
  [Subst]
matched [Subst] -> [Subst] -> [Subst]
forall a. [a] -> [a] -> [a]
++ [Subst]
deep

matchProgram :: Expression -> Program -> [Subst]
matchProgram :: Expression -> Program -> [Subst]
matchProgram Expression
ptn (Program Expression
exp) = Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp