{-# LANGUAGE LambdaCase #-}

-- 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 Expression -- !e, the second expression is scope, which is closest formation
  | 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)

defaultScope :: Expression
defaultScope :: Expression
defaultScope = [Binding] -> Expression
ExFormation [Attribute -> Binding
BiVoid Attribute
AtRho]

-- 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 -> Expression -> [Subst]
matchBinding :: Binding -> Binding -> Expression -> [Subst]
matchBinding (BiVoid Attribute
pattr) (BiVoid Attribute
tattr) Expression
_ = Attribute -> Attribute -> [Subst]
matchAttribute Attribute
pattr Attribute
tattr
matchBinding (BiDelta String
pbts) (BiDelta String
tbts) Expression
_
  | 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) Expression
_ = [String -> MetaValue -> Subst
substSingle String
meta (String -> MetaValue
MvBytes String
tBts)]
matchBinding (BiLambda String
pFunc) (BiLambda String
tFunc) Expression
_
  | 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) Expression
_ = [String -> MetaValue -> Subst
substSingle String
meta (String -> MetaValue
MvFunction String
tFunc)]
matchBinding (BiTau Attribute
pattr Expression
pexp) (BiTau Attribute
tattr Expression
texp) Expression
scope = [Subst] -> [Subst] -> [Subst]
combineMany (Attribute -> Attribute -> [Subst]
matchAttribute Attribute
pattr Attribute
tattr) (Expression -> Expression -> Expression -> [Subst]
matchExpression Expression
pexp Expression
texp Expression
scope)
matchBinding Binding
_ Binding
_ Expression
_ = []

-- Match bindings with ordering
matchBindings :: [Binding] -> [Binding] -> Expression -> [Subst]
matchBindings :: [Binding] -> [Binding] -> Expression -> [Subst]
matchBindings [] [] Expression
_ = [Subst
substEmpty]
matchBindings [] [Binding]
_ Expression
_ = []
matchBindings ((BiMeta String
name) : [Binding]
pbs) [Binding]
tbs Expression
scope =
  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]]
   in [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] -> Expression -> [Subst]
matchBindings [Binding]
pbs [Binding]
after Expression
scope
        ]
matchBindings (Binding
pb : [Binding]
pbs) (Binding
tb : [Binding]
tbs) Expression
scope = [Subst] -> [Subst] -> [Subst]
combineMany (Binding -> Binding -> Expression -> [Subst]
matchBinding Binding
pb Binding
tb Expression
scope) ([Binding] -> [Binding] -> Expression -> [Subst]
matchBindings [Binding]
pbs [Binding]
tbs Expression
scope)
matchBindings [Binding]
_ [Binding]
_ Expression
_ = []

-- 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 -> Expression -> ([Subst], [Tail])
tailExpressions :: Expression -> Expression -> Expression -> ([Subst], [Tail])
tailExpressions Expression
ptn Expression
tgt Expression
scope = case Expression -> Expression -> Maybe ([Subst], [Tail])
tailExpressionsReversed Expression
ptn Expression
tgt of
  Just ([Subst]
substs, [Tail]
tails) -> ([Subst]
substs, [Tail] -> [Tail]
forall a. [a] -> [a]
reverse [Tail]
tails)
  Maybe ([Subst], [Tail])
_ -> ([], [])
  where
    tailExpressionsReversed :: Expression -> Expression -> Maybe ([Subst], [Tail])
    tailExpressionsReversed :: Expression -> Expression -> Maybe ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
tgt' = case Expression -> Expression -> Expression -> [Subst]
matchExpression Expression
ptn' Expression
tgt' Expression
scope of
      [] -> case Expression
tgt' of
        ExDispatch Expression
expr Attribute
attr -> do
          ([Subst]
substs, [Tail]
tails) <- Expression -> Expression -> Maybe ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
expr
          ([Subst], [Tail]) -> Maybe ([Subst], [Tail])
forall a. a -> Maybe a
Just ([Subst]
substs, Attribute -> Tail
TaDispatch Attribute
attr Tail -> [Tail] -> [Tail]
forall a. a -> [a] -> [a]
: [Tail]
tails)
        ExApplication Expression
expr Binding
tau -> do
          ([Subst]
substs, [Tail]
tails) <- Expression -> Expression -> Maybe ([Subst], [Tail])
tailExpressionsReversed Expression
ptn' Expression
expr
          if Bool -> Bool
not ([Tail] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tail]
tails) Bool -> Bool -> Bool
&& Tail -> Bool
isDispatch ([Tail] -> Tail
forall a. HasCallStack => [a] -> a
head [Tail]
tails)
            then ([Subst], [Tail]) -> Maybe ([Subst], [Tail])
forall a. a -> Maybe a
Just ([Subst]
substs, Binding -> Tail
TaApplication Binding
tau Tail -> [Tail] -> [Tail]
forall a. a -> [a] -> [a]
: [Tail]
tails)
            else Maybe ([Subst], [Tail])
forall a. Maybe a
Nothing
          where
            isDispatch :: Tail -> Bool
            isDispatch :: Tail -> Bool
isDispatch = \case
              TaDispatch Attribute
_ -> Bool
True
              TaApplication Binding
_ -> Bool
False
        Expression
_ -> ([Subst], [Tail]) -> Maybe ([Subst], [Tail])
forall a. a -> Maybe a
Just ([], [])
      [Subst]
substs -> ([Subst], [Tail]) -> Maybe ([Subst], [Tail])
forall a. a -> Maybe a
Just ([Subst]
substs, [])

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

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

-- Match expression with deep nested expression(s) matching
matchExpressionDeep :: Expression -> Expression -> Expression -> [Subst]
matchExpressionDeep :: Expression -> Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
tgt Expression
scope =
  let matched :: [Subst]
matched = Expression -> Expression -> Expression -> [Subst]
matchExpression Expression
ptn Expression
tgt Expression
scope
      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
bd -> Binding -> Expression -> Expression -> [Subst]
matchBindingExpression Binding
bd Expression
ptn ([Binding] -> Expression
ExFormation [Binding]
bds)) [Binding]
bds
        ExDispatch Expression
exp Attribute
_ -> Expression -> Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp Expression
scope
        ExApplication Expression
exp Binding
tau -> Expression -> Expression -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp Expression
scope [Subst] -> [Subst] -> [Subst]
forall a. [a] -> [a] -> [a]
++ Binding -> Expression -> Expression -> [Subst]
matchBindingExpression Binding
tau Expression
ptn Expression
scope
        Expression
_ -> []
   in [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 -> Expression -> [Subst]
matchExpressionDeep Expression
ptn Expression
exp Expression
defaultScope