{- FOURMOLU_DISABLE -}
-- The MIT License (MIT)

-- Copyright (c) 2016-2024 Objectionary.com

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
{- FOURMOLU_ENABLE -}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.EO.Phi.Rules.Fast where

import Data.List.NonEmpty qualified as NonEmpty
import Language.EO.Phi.Rules.Common
import Language.EO.Phi.Rules.Yaml qualified as Yaml
import Language.EO.Phi.Syntax

-- $setup
-- >>> :set -XOverloadedStrings

withBinding :: (Context -> Object -> Object) -> Context -> Binding -> Binding
withBinding :: (Context -> Object -> Object) -> Context -> Binding -> Binding
withBinding Context -> Object -> Object
f Context
ctx = \case
  AlphaBinding' Attribute
Rho Object
obj -> Attribute -> Object -> Binding
AlphaBinding' Attribute
Rho Object
obj -- do not apply f inside ρ-bindings
  AlphaBinding' Attribute
a Object
obj -> Attribute -> Object -> Binding
AlphaBinding' Attribute
a (Context -> Object -> Object
f Context
ctx{currentAttr = a} Object
obj)
  b :: Binding
b@AlphaBinding''{} -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
  Binding
binding -> Binding
binding

isLambdaBinding :: Binding -> Bool
isLambdaBinding :: Binding -> Bool
isLambdaBinding LambdaBinding{} = Bool
True
isLambdaBinding Binding
_ = Bool
False

withSubObjects :: (Context -> Object -> Object) -> Context -> Object -> Object
withSubObjects :: (Context -> Object -> Object) -> Context -> Object -> Object
withSubObjects Context -> Object -> Object
f Context
ctx = Object -> Object
go
 where
  go :: Object -> Object
go = \case
    root :: Object
root@(Formation [Binding]
bindings)
      | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isEmptyBinding [Binding]
bindings) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) ->
          let extendedContext :: Context
extendedContext = (Object -> Context -> Context
extendContextWith Object
root Context
ctx){insideFormation = True}
           in [Binding] -> Object
Formation
                [ (Context -> Object -> Object) -> Context -> Binding -> Binding
withBinding Context -> Object -> Object
f Context
extendedContext Binding
binding
                | Binding
binding <- [Binding]
bindings
                ]
    Application Object
obj [Binding]
bindings ->
      Object -> [Binding] -> Object
Application
        (Context -> Object -> Object
f Context
ctx Object
obj)
        [ (Context -> Object -> Object) -> Context -> Binding -> Binding
withBinding Context -> Object -> Object
f Context
ctx Binding
binding
        | Binding
binding <- [Binding]
bindings
        ]
    ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Context -> Object -> Object
f Context
ctx Object
obj) Attribute
a
    Object
obj -> Object
obj

-- | Normalize an object, following a version of call-by-value strategy:
--
-- 1. Apply rules in subobjects/subterms before applying a rule at root.
-- 2. Do not apply rules under formations with at least one void (empty) binding.
--
-- > runWithYegorRules applyRulesInsideOut "⟦ x ↦ ⟦⟧, y ↦ ⟦ z ↦ ⟦ w ↦ ξ.ρ.ρ.x ⟧ ⟧ ⟧.y.z.w"
-- ⟦ ρ ↦ ⟦ ρ ↦ ⟦ ⟧ ⟧ ⟧
applyRulesInsideOut :: Context -> Object -> Object
applyRulesInsideOut :: Context -> Object -> Object
applyRulesInsideOut Context
ctx Object
obj = do
  let obj' :: Object
obj' = (Context -> Object -> Object) -> Context -> Object -> Object
withSubObjects Context -> Object -> Object
applyRulesInsideOut Context
ctx Object
obj
  case Context -> Object -> [(String, Object)]
applyOneRuleAtRoot Context
ctx Object
obj' of
    [] ->
      -- trace ("No rule can be applied to object\n   " <> printTree obj') $
      Object
obj'
    (String
_ruleName, Object
obj'') : [(String, Object)]
_ ->
      -- trace (ruleName <> ": \n   " <> printTree obj' <> "\n → " <> printTree obj'') $
      Context -> Object -> Object
applyRulesInsideOut Context
ctx Object
obj''

fastYegorInsideOutAsRule :: NamedRule
fastYegorInsideOutAsRule :: NamedRule
fastYegorInsideOutAsRule = (String
"Yegor's rules (hardcoded)", \Context
ctx Object
obj -> [Context -> Object -> Object
fastYegorInsideOut Context
ctx Object
obj])

fastYegorInsideOutBinding :: Context -> Binding -> Binding
fastYegorInsideOutBinding :: Context -> Binding -> Binding
fastYegorInsideOutBinding Context
ctx (AlphaBinding AttributeSugar
a Object
obj) = AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Context -> Object -> Object
fastYegorInsideOut Context
ctx Object
obj)
fastYegorInsideOutBinding Context
_ Binding
binding = Binding
binding

fastYegorInsideOut :: Context -> Object -> Object
fastYegorInsideOut :: Context -> Object -> Object
fastYegorInsideOut Context
ctx = \case
  Object
root | Context -> Bool
insideSubObject Context
ctx -> Object
root -- this rule is only applied at root
  root :: Object
root@Object
GlobalObject
    | Bool -> Bool
not (Context -> Bool
insideFormation Context
ctx) ->
        NonEmpty Object -> Object
forall a. NonEmpty a -> a
NonEmpty.last (Context -> NonEmpty Object
outerFormations Context
ctx)
    | Bool
otherwise -> Object
root
  root :: Object
root@Object
ThisObject
    | Bool -> Bool
not (Context -> Bool
insideFormation Context
ctx) ->
        NonEmpty Object -> Object
forall a. NonEmpty a -> a
NonEmpty.head (Context -> NonEmpty Object
outerFormations Context
ctx)
    | Bool
otherwise -> Object
root
  ObjectDispatch Object
obj Attribute
a ->
    case Context -> Object -> Object
fastYegorInsideOut Context
ctx Object
obj of
      this :: Object
this@(Formation [Binding]
bindings) ->
        case Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
a [Binding]
bindings of
          Just Object
objA -> Context -> Object -> Object
fastYegorInsideOut Context
ctx (Object -> Object -> Object
Yaml.substThis Object
this Object
objA)
          Maybe Object
Nothing ->
            case Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
Phi [Binding]
bindings of
              Just Object
objPhi -> Context -> Object -> Object
fastYegorInsideOut Context
ctx (Object -> Attribute -> Object
ObjectDispatch (Object -> Object -> Object
Yaml.substThis Object
this Object
objPhi) Attribute
a)
              Maybe Object
Nothing
                | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
                | Bool
otherwise -> Object -> Attribute -> Object
ObjectDispatch Object
this Attribute
a
      Object
this -> Object -> Attribute -> Object
ObjectDispatch Object
this Attribute
a
  Application Object
obj [Binding]
argBindings ->
    case Context -> Object -> Object
fastYegorInsideOut Context
ctx Object
obj of
      obj' :: Object
obj'@(Formation [Binding]
bindings) -> do
        let argBindings' :: [Binding]
argBindings' = (Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Binding -> Binding
fastYegorInsideOutBinding Context
ctx) [Binding]
argBindings
        case [Binding]
argBindings' of
          [AlphaBinding' (Alpha AlphaIndex
"α0") Object
arg0, AlphaBinding' (Alpha AlphaIndex
"α1") Object
arg1, AlphaBinding' (Alpha AlphaIndex
"α2") Object
arg2] ->
            case (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter Binding -> Bool
isEmptyBinding [Binding]
bindings of
              EmptyBinding Attribute
a0 : EmptyBinding Attribute
a1 : EmptyBinding Attribute
a2 : [Binding]
_ ->
                [Binding] -> Object
Formation
                  ( Attribute -> Object -> Binding
AlphaBinding' Attribute
a0 Object
arg0
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: Attribute -> Object -> Binding
AlphaBinding' Attribute
a1 Object
arg1
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: Attribute -> Object -> Binding
AlphaBinding' Attribute
a2 Object
arg2
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [ Binding
binding
                        | Binding
binding <- [Binding]
bindings
                        , case Binding
binding of
                            EmptyBinding Attribute
x | Attribute
x Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute
a0, Attribute
a1, Attribute
a2] -> Bool
False
                            Binding
_ -> Bool
True
                        ]
                  )
              [Binding]
_
                | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
                | Bool
otherwise -> Object -> [Binding] -> Object
Application Object
obj' [Binding]
argBindings'
          [AlphaBinding' (Alpha AlphaIndex
"α0") Object
arg0, AlphaBinding' (Alpha AlphaIndex
"α1") Object
arg1] ->
            case (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter Binding -> Bool
isEmptyBinding [Binding]
bindings of
              EmptyBinding Attribute
a0 : EmptyBinding Attribute
a1 : [Binding]
_ ->
                [Binding] -> Object
Formation
                  ( Attribute -> Object -> Binding
AlphaBinding' Attribute
a0 Object
arg0
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: Attribute -> Object -> Binding
AlphaBinding' Attribute
a1 Object
arg1
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [ Binding
binding
                        | Binding
binding <- [Binding]
bindings
                        , case Binding
binding of
                            EmptyBinding Attribute
x | Attribute
x Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute
a0, Attribute
a1] -> Bool
False
                            Binding
_ -> Bool
True
                        ]
                  )
              [Binding]
_
                | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
                | Bool
otherwise -> Object -> [Binding] -> Object
Application Object
obj' [Binding]
argBindings'
          [AlphaBinding' (Alpha AlphaIndex
"α0") Object
arg0] ->
            case (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter Binding -> Bool
isEmptyBinding [Binding]
bindings of
              EmptyBinding Attribute
a0 : [Binding]
_ ->
                [Binding] -> Object
Formation
                  ( Attribute -> Object -> Binding
AlphaBinding' Attribute
a0 Object
arg0
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [ Binding
binding
                        | Binding
binding <- [Binding]
bindings
                        , case Binding
binding of
                            EmptyBinding Attribute
x | Attribute
x Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
a0 -> Bool
False
                            Binding
_ -> Bool
True
                        ]
                  )
              [Binding]
_
                | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
                | Bool
otherwise -> Object -> [Binding] -> Object
Application Object
obj' [Binding]
argBindings'
          [AlphaBinding' Attribute
a Object
argA]
            | Attribute -> Binding
EmptyBinding Attribute
a Binding -> [Binding] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Binding]
bindings ->
                [Binding] -> Object
Formation
                  ( Attribute -> Object -> Binding
AlphaBinding' Attribute
a Object
argA
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [ Binding
binding
                        | Binding
binding <- [Binding]
bindings
                        , case Binding
binding of
                            EmptyBinding Attribute
x | Attribute
x Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
a -> Bool
False
                            Binding
_ -> Bool
True
                        ]
                  )
            | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
          [DeltaBinding Bytes
bytes]
            | Binding
DeltaEmptyBinding Binding -> [Binding] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Binding]
bindings -> do
                [Binding] -> Object
Formation
                  ( Bytes -> Binding
DeltaBinding Bytes
bytes
                      Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [ Binding
binding
                        | Binding
binding <- [Binding]
bindings
                        , case Binding
binding of
                            Binding
DeltaEmptyBinding -> Bool
False
                            Binding
_ -> Bool
True
                        ]
                  )
            | Bool -> Bool
not ((Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings) -> Object
Termination
          [Binding]
_ -> Object -> [Binding] -> Object
Application Object
obj' [Binding]
argBindings'
      Object
obj' -> Object -> [Binding] -> Object
Application Object
obj' ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Binding -> Binding
fastYegorInsideOutBinding Context
ctx) [Binding]
argBindings)
  root :: Object
root@(Formation [Binding]
bindings)
    | (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isEmptyBinding [Binding]
bindings Bool -> Bool -> Bool
|| (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isLambdaBinding [Binding]
bindings -> Object
root
    | Bool
otherwise ->
        [Binding] -> Object
Formation
          [ Binding
binding'
          | Binding
binding <- [Binding]
bindings
          , let binding' :: Binding
binding' =
                  case Binding
binding of
                    AlphaBinding' Attribute
Rho Object
_ -> Binding
binding
                    AlphaBinding' Attribute
a Object
objA -> do
                      let ctx' :: Context
ctx' = (Object -> Context -> Context
extendContextWith Object
root Context
ctx){insideFormation = True, currentAttr = a}
                      Attribute -> Object -> Binding
AlphaBinding' Attribute
a (Context -> Object -> Object
fastYegorInsideOut Context
ctx' Object
objA)
                    b :: Binding
b@AlphaBinding''{} -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
                    Binding
_ -> Binding
binding
          ]
  obj :: Object
obj@Object
GlobalObjectPhiOrg -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  Object
Termination -> Object
Termination
  MetaSubstThis{} -> String -> Object
forall a. HasCallStack => String -> a
error String
"impossible MetaSubstThis!"
  MetaContextualize{} -> String -> Object
forall a. HasCallStack => String -> a
error String
"impossible MetaContextualize!"
  MetaObject{} -> String -> Object
forall a. HasCallStack => String -> a
error String
"impossible MetaObject!"
  MetaTailContext{} -> String -> Object
forall a. HasCallStack => String -> a
error String
"impossible MetaTailContext!"
  MetaFunction{} -> String -> Object
forall a. HasCallStack => String -> a
error String
"impossible MetaFunction!"
  obj :: Object
obj@ConstString{} -> Object
obj -- fastYegorInsideOut ctx (desugar obj)
  obj :: Object
obj@ConstStringRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj -- fastYegorInsideOut ctx (desugar obj)
  obj :: Object
obj@ConstInt{} -> Object
obj -- fastYegorInsideOut ctx (desugar obj)
  obj :: Object
obj@ConstIntRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj -- fastYegorInsideOut ctx (desugar obj)
  obj :: Object
obj@ConstFloat{} -> Object
obj -- fastYegorInsideOut ctx (desugar obj)
  obj :: Object
obj@ConstFloatRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj -- fastYegorInsideOut ctx (desugar obj)