{- 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 -}
{-# HLINT ignore "Use &&" #-}
{-# LANGUAGE DeriveFunctor #-}
{-# HLINT ignore "Redundant fmap" #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Language.EO.Phi.Rules.Common where

import Control.Applicative (Alternative ((<|>)), asum)
import Control.Arrow (Arrow (first))
import Control.Monad
import Data.HashMap.Strict qualified as HashMap
import Data.List (minimumBy, nubBy, sortOn)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.Ord (comparing)
import Language.EO.Phi.Syntax (
  Attribute (..),
  Binding (..),
  BindingsMetaId (BindingsMetaId),
  Bytes,
  LabelId (LabelId),
  LabelMetaId (LabelMetaId),
  Object (..),
  Program (..),
  desugar,
  errorExpectedDesugaredBinding,
  errorExpectedDesugaredObject,
  printTree,
  pattern AlphaBinding',
  pattern AlphaBinding'',
 )

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XOverloadedLists
-- >>> import Language.EO.Phi.Syntax

-- | State of evaluation is not needed yet, but it might be in the future
type EvaluationState = ()

type NamedRule = (String, Rule)
type Atoms = HashMap.HashMap String (String -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState))

data Context = Context
  { Context -> Bool
builtinRules :: Bool
  , Context -> [NamedRule]
allRules :: [NamedRule]
  , Context -> Atoms
enabledAtoms :: Atoms
  , Context -> Atoms
knownAtoms :: Atoms
  , Context -> NonEmpty Object
outerFormations :: NonEmpty Object
  , Context -> Attribute
currentAttr :: Attribute
  , Context -> Bool
insideFormation :: Bool
  -- ^ Temporary hack for applying Ksi and Phi rules when dataizing
  , Context -> Bool
insideAbstractFormation :: Bool
  , Context -> Bool
dataizePackage :: Bool
  -- ^ Temporary flag to only dataize Package attributes for the top-level formation.
  , Context -> Bool
minimizeTerms :: Bool
  , Context -> Bool
insideSubObject :: Bool
  }

sameContext :: Context -> Context -> Bool
sameContext :: Context -> Context -> Bool
sameContext Context
ctx1 Context
ctx2 =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ Context -> NonEmpty Object
outerFormations Context
ctx1 NonEmpty Object -> NonEmpty Object -> Bool
forall a. Eq a => a -> a -> Bool
== Context -> NonEmpty Object
outerFormations Context
ctx2
    , Context -> Attribute
currentAttr Context
ctx1 Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Context -> Attribute
currentAttr Context
ctx2
    ]

-- | A rule tries to apply a transformation to the root object, if possible.
type Rule = Context -> Object -> [Object]

applyOneRuleAtRoot :: Context -> Object -> [(String, Object)]
applyOneRuleAtRoot :: Context -> Object -> [([Char], Object)]
applyOneRuleAtRoot ctx :: Context
ctx@Context{Bool
[NamedRule]
NonEmpty Object
Atoms
Attribute
builtinRules :: Context -> Bool
allRules :: Context -> [NamedRule]
enabledAtoms :: Context -> Atoms
knownAtoms :: Context -> Atoms
outerFormations :: Context -> NonEmpty Object
currentAttr :: Context -> Attribute
insideFormation :: Context -> Bool
insideAbstractFormation :: Context -> Bool
dataizePackage :: Context -> Bool
minimizeTerms :: Context -> Bool
insideSubObject :: Context -> Bool
builtinRules :: Bool
allRules :: [NamedRule]
enabledAtoms :: Atoms
knownAtoms :: Atoms
outerFormations :: NonEmpty Object
currentAttr :: Attribute
insideFormation :: Bool
insideAbstractFormation :: Bool
dataizePackage :: Bool
minimizeTerms :: Bool
insideSubObject :: Bool
..} Object
obj =
  (([Char], Object) -> ([Char], Object) -> Bool)
-> [([Char], Object)] -> [([Char], Object)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy
    ([Char], Object) -> ([Char], Object) -> Bool
equalObjectNamed
    [ ([Char]
ruleName, Object
obj')
    | ([Char]
ruleName, Rule
rule) <- [NamedRule]
allRules
    , Object
obj' <- Rule
rule Context
ctx Object
obj
    ]

extendContextWith :: Object -> Context -> Context
extendContextWith :: Object -> Context -> Context
extendContextWith Object
obj Context
ctx =
  Context
ctx
    { outerFormations = obj <| outerFormations ctx
    }

isEmptyBinding :: Binding -> Bool
isEmptyBinding :: Binding -> Bool
isEmptyBinding EmptyBinding{} = Bool
True
isEmptyBinding DeltaEmptyBinding{} = Bool
True
isEmptyBinding Binding
_ = Bool
False

withSubObject :: (Context -> Object -> [(String, Object)]) -> Context -> Object -> [(String, Object)]
withSubObject :: (Context -> Object -> [([Char], Object)])
-> Context -> Object -> [([Char], Object)]
withSubObject Context -> Object -> [([Char], Object)]
f Context
ctx Object
root =
  Context -> Object -> [([Char], Object)]
f Context
ctx Object
root
    [([Char], Object)] -> [([Char], Object)] -> [([Char], Object)]
forall a. [a] -> [a] -> [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> [([Char], Object)]
go Object
root
 where
  subctx :: Context
subctx = Context
ctx{insideSubObject = True}
  go :: Object -> [([Char], Object)]
go = \case
    Formation [Binding]
bindings ->
      ([Binding] -> Object) -> ([Char], [Binding]) -> ([Char], Object)
forall a b name. (a -> b) -> (name, a) -> (name, b)
propagateName1 [Binding] -> Object
Formation
        (([Char], [Binding]) -> ([Char], Object))
-> [([Char], [Binding])] -> [([Char], Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Object -> [([Char], Object)])
-> Context -> [Binding] -> [([Char], [Binding])]
withSubObjectBindings Context -> Object -> [([Char], Object)]
f ((Object -> Context -> Context
extendContextWith Object
root Context
subctx){insideFormation = True, insideAbstractFormation = isAbstract}) [Binding]
bindings
     where
      isAbstract :: Bool
isAbstract = (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isEmptyBinding [Binding]
bindings
    Application Object
obj [Binding]
bindings ->
      [[([Char], Object)]] -> [([Char], Object)]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ (Object -> [Binding] -> Object)
-> ([Char], Object) -> [Binding] -> ([Char], Object)
forall a b c name. (a -> b -> c) -> (name, a) -> b -> (name, c)
propagateName2 Object -> [Binding] -> Object
Application (([Char], Object) -> [Binding] -> ([Char], Object))
-> [([Char], Object)] -> [[Binding] -> ([Char], Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Object -> [([Char], Object)])
-> Context -> Object -> [([Char], Object)]
withSubObject Context -> Object -> [([Char], Object)]
f Context
subctx Object
obj [[Binding] -> ([Char], Object)]
-> [[Binding]] -> [([Char], Object)]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Binding] -> [[Binding]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Binding]
bindings
        , ([Binding] -> Object) -> ([Char], [Binding]) -> ([Char], Object)
forall a b name. (a -> b) -> (name, a) -> (name, b)
propagateName1 (Object -> [Binding] -> Object
Application Object
obj) (([Char], [Binding]) -> ([Char], Object))
-> [([Char], [Binding])] -> [([Char], Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Object -> [([Char], Object)])
-> Context -> [Binding] -> [([Char], [Binding])]
withSubObjectBindings Context -> Object -> [([Char], Object)]
f Context
subctx [Binding]
bindings
        ]
    ObjectDispatch Object
obj Attribute
a -> (Object -> Attribute -> Object)
-> ([Char], Object) -> Attribute -> ([Char], Object)
forall a b c name. (a -> b -> c) -> (name, a) -> b -> (name, c)
propagateName2 Object -> Attribute -> Object
ObjectDispatch (([Char], Object) -> Attribute -> ([Char], Object))
-> [([Char], Object)] -> [Attribute -> ([Char], Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Object -> [([Char], Object)])
-> Context -> Object -> [([Char], Object)]
withSubObject Context -> Object -> [([Char], Object)]
f Context
subctx Object
obj [Attribute -> ([Char], Object)]
-> [Attribute] -> [([Char], Object)]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Attribute -> [Attribute]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
a
    GlobalObject{} -> []
    obj :: Object
obj@GlobalObjectPhiOrg{} -> Object -> [([Char], Object)]
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    ThisObject{} -> []
    Object
Termination -> []
    MetaObject ObjectMetaId
_ -> []
    MetaFunction MetaFunctionName
_ Object
_ -> []
    MetaTailContext{} -> []
    MetaSubstThis Object
_ Object
_ -> []
    MetaContextualize Object
_ Object
_ -> []
    ConstString{} -> []
    obj :: Object
obj@ConstStringRaw{} -> Object -> [([Char], Object)]
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    ConstInt{} -> []
    obj :: Object
obj@ConstIntRaw{} -> Object -> [([Char], Object)]
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    ConstFloat{} -> []
    obj :: Object
obj@ConstFloatRaw{} -> Object -> [([Char], Object)]
forall a. Object -> a
errorExpectedDesugaredObject Object
obj

-- | Given a unary function that operates only on plain objects,
-- converts it to a function that operates on named objects
propagateName1 :: (a -> b) -> (name, a) -> (name, b)
propagateName1 :: forall a b name. (a -> b) -> (name, a) -> (name, b)
propagateName1 a -> b
f (name
name, a
obj) = (name
name, a -> b
f a
obj)

-- | Given a binary function that operates only on plain objects,
-- converts it to a function that operates on named objects
propagateName2 :: (a -> b -> c) -> (name, a) -> b -> (name, c)
propagateName2 :: forall a b c name. (a -> b -> c) -> (name, a) -> b -> (name, c)
propagateName2 a -> b -> c
f (name
name, a
obj) b
bs = (name
name, a -> b -> c
f a
obj b
bs)

withSubObjectBindings :: (Context -> Object -> [(String, Object)]) -> Context -> [Binding] -> [(String, [Binding])]
withSubObjectBindings :: (Context -> Object -> [([Char], Object)])
-> Context -> [Binding] -> [([Char], [Binding])]
withSubObjectBindings Context -> Object -> [([Char], Object)]
_ Context
_ [] = []
withSubObjectBindings Context -> Object -> [([Char], Object)]
f Context
ctx (b :: Binding
b@(AlphaBinding' Attribute
Rho Object
_) : [Binding]
bs) =
  -- do not apply rules inside ρ-bindings
  [([Char]
name, Binding
b Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bs') | ([Char]
name, [Binding]
bs') <- (Context -> Object -> [([Char], Object)])
-> Context -> [Binding] -> [([Char], [Binding])]
withSubObjectBindings Context -> Object -> [([Char], Object)]
f Context
ctx [Binding]
bs]
withSubObjectBindings Context -> Object -> [([Char], Object)]
f Context
ctx (Binding
b : [Binding]
bs) =
  [[([Char], [Binding])]] -> [([Char], [Binding])]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ [([Char]
name, Binding
b' Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bs) | ([Char]
name, Binding
b') <- (Context -> Object -> [([Char], Object)])
-> Context -> Binding -> [([Char], Binding)]
withSubObjectBinding Context -> Object -> [([Char], Object)]
f Context
ctx Binding
b]
    , [([Char]
name, Binding
b Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bs') | ([Char]
name, [Binding]
bs') <- (Context -> Object -> [([Char], Object)])
-> Context -> [Binding] -> [([Char], [Binding])]
withSubObjectBindings Context -> Object -> [([Char], Object)]
f Context
ctx [Binding]
bs]
    ]

withSubObjectBinding :: (Context -> Object -> [(String, Object)]) -> Context -> Binding -> [(String, Binding)]
withSubObjectBinding :: (Context -> Object -> [([Char], Object)])
-> Context -> Binding -> [([Char], Binding)]
withSubObjectBinding Context -> Object -> [([Char], Object)]
f Context
ctx = \case
  AlphaBinding' Attribute
a Object
obj -> (Object -> Binding) -> ([Char], Object) -> ([Char], Binding)
forall a b name. (a -> b) -> (name, a) -> (name, b)
propagateName1 (Attribute -> Object -> Binding
AlphaBinding' Attribute
a) (([Char], Object) -> ([Char], Binding))
-> [([Char], Object)] -> [([Char], Binding)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Object -> [([Char], Object)])
-> Context -> Object -> [([Char], Object)]
withSubObject Context -> Object -> [([Char], Object)]
f (Context
ctx{currentAttr = a}) Object
obj
  b :: Binding
b@AlphaBinding{} -> Binding -> [([Char], Binding)]
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
  b :: Binding
b@AlphaBindingSugar{} -> Binding -> [([Char], Binding)]
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
  EmptyBinding{} -> []
  DeltaBinding{} -> []
  DeltaEmptyBinding{} -> []
  MetaDeltaBinding{} -> []
  LambdaBinding{} -> []
  MetaBindings BindingsMetaId
_ -> []

applyOneRule :: Context -> Object -> [(String, Object)]
applyOneRule :: Context -> Object -> [([Char], Object)]
applyOneRule = (Context -> Object -> [([Char], Object)])
-> Context -> Object -> [([Char], Object)]
withSubObject Context -> Object -> [([Char], Object)]
applyOneRuleAtRoot

isNF :: Context -> Object -> Bool
isNF :: Context -> Object -> Bool
isNF Context
ctx = [([Char], Object)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([([Char], Object)] -> Bool)
-> (Object -> [([Char], Object)]) -> Object -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Object -> [([Char], Object)]
applyOneRule Context
ctx

-- | Apply rules until we get a normal form.
applyRules :: Context -> Object -> [Object]
applyRules :: Rule
applyRules Context
ctx Object
obj = ApplicationLimits -> Rule
applyRulesWith (Int -> ApplicationLimits
defaultApplicationLimits (Object -> Int
objectSize Object
obj)) Context
ctx Object
obj

data ApplicationLimits = ApplicationLimits
  { ApplicationLimits -> Int
maxDepth :: Int
  , ApplicationLimits -> Int
maxTermSize :: Int
  }

defaultApplicationLimits :: Int -> ApplicationLimits
defaultApplicationLimits :: Int -> ApplicationLimits
defaultApplicationLimits Int
sourceTermSize =
  ApplicationLimits
    { maxDepth :: Int
maxDepth = Int
130
    , maxTermSize :: Int
maxTermSize = Int
sourceTermSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000
    }

objectSize :: Object -> Int
objectSize :: Object -> Int
objectSize = \case
  Formation [Binding]
bindings -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Binding -> Int) -> [Binding] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Int
bindingSize [Binding]
bindings)
  Application Object
obj [Binding]
bindings -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Object -> Int
objectSize Object
obj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Binding -> Int) -> [Binding] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Int
bindingSize [Binding]
bindings)
  ObjectDispatch Object
obj Attribute
_attr -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Object -> Int
objectSize Object
obj
  Object
GlobalObject -> Int
1
  -- TODO #617:30m
  -- @fizruk, why desugar here and not assume the object is desugared?
  -- Is it because we sometimes bounce between sugared and desugared versions?
  --
  -- Should we introduce a smart constructor with a desugared object inside?
  obj :: Object
obj@Object
GlobalObjectPhiOrg -> Object -> Int
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  Object
ThisObject -> Int
1
  Object
Termination -> Int
1
  obj :: Object
obj@MetaObject{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
obj)
  obj :: Object
obj@MetaFunction{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
obj)
  obj :: Object
obj@MetaSubstThis{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
obj)
  obj :: Object
obj@MetaContextualize{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
obj)
  obj :: Object
obj@MetaTailContext{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
obj)
  obj :: Object
obj@ConstString{} -> Object -> Int
objectSize (Object -> Object
desugar Object
obj)
  obj :: Object
obj@ConstStringRaw{} -> Object -> Int
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  obj :: Object
obj@ConstInt{} -> Object -> Int
objectSize (Object -> Object
desugar Object
obj)
  obj :: Object
obj@ConstIntRaw{} -> Object -> Int
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  obj :: Object
obj@ConstFloat{} -> Object -> Int
objectSize (Object -> Object
desugar Object
obj)
  obj :: Object
obj@ConstFloatRaw{} -> Object -> Int
forall a. Object -> a
errorExpectedDesugaredObject Object
obj

bindingSize :: Binding -> Int
bindingSize :: Binding -> Int
bindingSize = \case
  AlphaBinding AttributeSugar
_attr Object
obj -> Object -> Int
objectSize Object
obj
  EmptyBinding Attribute
_attr -> Int
1
  DeltaBinding Bytes
_bytes -> Int
1
  Binding
DeltaEmptyBinding -> Int
1
  LambdaBinding Function
_lam -> Int
1
  obj :: Binding
obj@MetaDeltaBinding{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Binding -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Binding
obj)
  obj :: Binding
obj@MetaBindings{} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible: expected a desugared object, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Binding -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Binding
obj)
  b :: Binding
b@AlphaBindingSugar{} -> Binding -> Int
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b

-- | A variant of `applyRules` with a maximum application depth.
applyRulesWith :: ApplicationLimits -> Context -> Object -> [Object]
applyRulesWith :: ApplicationLimits -> Rule
applyRulesWith limits :: ApplicationLimits
limits@ApplicationLimits{Int
maxDepth :: ApplicationLimits -> Int
maxTermSize :: ApplicationLimits -> Int
maxDepth :: Int
maxTermSize :: Int
..} Context
ctx Object
obj
  | Int
maxDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Object
obj]
  | Context -> Object -> Bool
isNF Context
ctx Object
obj = [Object
obj]
  | Bool
otherwise =
      (Object -> Object -> Bool) -> [Object] -> [Object]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy
        Object -> Object -> Bool
equalObject
        [ Object
obj''
        | ([Char]
_ruleName, Object
obj') <- Context -> Object -> [([Char], Object)]
applyOneRule Context
ctx Object
obj
        , Object
obj'' <-
            if Object -> Int
objectSize Object
obj' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxTermSize
              then ApplicationLimits -> Rule
applyRulesWith ApplicationLimits
limits{maxDepth = maxDepth - 1} Context
ctx Object
obj'
              else [Object
obj']
        ]

equalProgram :: Program -> Program -> Bool
equalProgram :: Program -> Program -> Bool
equalProgram (Program [Binding]
bindings1) (Program [Binding]
bindings2) = Object -> Object -> Bool
equalObject ([Binding] -> Object
Formation [Binding]
bindings1) ([Binding] -> Object
Formation [Binding]
bindings2)

equalObject :: Object -> Object -> Bool
equalObject :: Object -> Object -> Bool
equalObject (Formation [Binding]
bindings1) (Formation [Binding]
bindings2) =
  [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bindings1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bindings2 Bool -> Bool -> Bool
&& [Binding] -> [Binding] -> Bool
equalBindings [Binding]
bindings1 [Binding]
bindings2
equalObject (Application Object
obj1 [Binding]
bindings1) (Application Object
obj2 [Binding]
bindings2) =
  Object -> Object -> Bool
equalObject Object
obj1 Object
obj2 Bool -> Bool -> Bool
&& [Binding] -> [Binding] -> Bool
equalBindings [Binding]
bindings1 [Binding]
bindings2
equalObject (ObjectDispatch Object
obj1 Attribute
attr1) (ObjectDispatch Object
obj2 Attribute
attr2) =
  Object -> Object -> Bool
equalObject Object
obj1 Object
obj2 Bool -> Bool -> Bool
&& Attribute
attr1 Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr2
equalObject Object
obj1 Object
obj2 = Object
obj1 Object -> Object -> Bool
forall a. Eq a => a -> a -> Bool
== Object
obj2

equalObjectNamed :: (String, Object) -> (String, Object) -> Bool
equalObjectNamed :: ([Char], Object) -> ([Char], Object) -> Bool
equalObjectNamed ([Char], Object)
x ([Char], Object)
y = ([Char], Object) -> Object
forall a b. (a, b) -> b
snd ([Char], Object)
x Object -> Object -> Bool
`equalObject` ([Char], Object) -> Object
forall a b. (a, b) -> b
snd ([Char], Object)
y

equalBindings :: [Binding] -> [Binding] -> Bool
equalBindings :: [Binding] -> [Binding] -> Bool
equalBindings [Binding]
bindings1 [Binding]
bindings2 = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Binding -> Binding -> Bool) -> [Binding] -> [Binding] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Binding -> Binding -> Bool
equalBinding ((Binding -> Attribute) -> [Binding] -> [Binding]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Binding -> Attribute
attr [Binding]
bindings1) ((Binding -> Attribute) -> [Binding] -> [Binding]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Binding -> Attribute
attr [Binding]
bindings2))
 where
  attr :: Binding -> Attribute
attr (AlphaBinding' Attribute
a Object
_) = Attribute
a
  attr b :: Binding
b@(AlphaBinding''{}) = Binding -> Attribute
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
  attr (EmptyBinding Attribute
a) = Attribute
a
  attr (DeltaBinding Bytes
_) = LabelId -> Attribute
Label ([Char] -> LabelId
LabelId [Char]
"Δ")
  attr Binding
DeltaEmptyBinding = LabelId -> Attribute
Label ([Char] -> LabelId
LabelId [Char]
"Δ")
  attr (MetaDeltaBinding BytesMetaId
_) = LabelId -> Attribute
Label ([Char] -> LabelId
LabelId [Char]
"Δ")
  attr (LambdaBinding Function
_) = LabelId -> Attribute
Label ([Char] -> LabelId
LabelId [Char]
"λ")
  attr (MetaBindings (BindingsMetaId [Char]
metaId)) = LabelMetaId -> Attribute
MetaAttr ([Char] -> LabelMetaId
LabelMetaId [Char]
metaId)
  attr b :: Binding
b@AlphaBindingSugar{} = Binding -> Attribute
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b

equalBinding :: Binding -> Binding -> Bool
equalBinding :: Binding -> Binding -> Bool
equalBinding (AlphaBinding AttributeSugar
attr1 Object
obj1) (AlphaBinding AttributeSugar
attr2 Object
obj2) = AttributeSugar
attr1 AttributeSugar -> AttributeSugar -> Bool
forall a. Eq a => a -> a -> Bool
== AttributeSugar
attr2 Bool -> Bool -> Bool
&& Object -> Object -> Bool
equalObject Object
obj1 Object
obj2
equalBinding Binding
b1 Binding
b2 = Binding
b1 Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
b2

-- * Chain variants

data LogEntry log = LogEntry
  { forall log. LogEntry log -> [Char]
logEntryMessage :: String
  , forall log. LogEntry log -> log
logEntryLog :: log
  , forall log. LogEntry log -> Int
logEntryLevel :: Int
  }
  deriving (Int -> LogEntry log -> [Char] -> [Char]
[LogEntry log] -> [Char] -> [Char]
LogEntry log -> [Char]
(Int -> LogEntry log -> [Char] -> [Char])
-> (LogEntry log -> [Char])
-> ([LogEntry log] -> [Char] -> [Char])
-> Show (LogEntry log)
forall log. Show log => Int -> LogEntry log -> [Char] -> [Char]
forall log. Show log => [LogEntry log] -> [Char] -> [Char]
forall log. Show log => LogEntry log -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall log. Show log => Int -> LogEntry log -> [Char] -> [Char]
showsPrec :: Int -> LogEntry log -> [Char] -> [Char]
$cshow :: forall log. Show log => LogEntry log -> [Char]
show :: LogEntry log -> [Char]
$cshowList :: forall log. Show log => [LogEntry log] -> [Char] -> [Char]
showList :: [LogEntry log] -> [Char] -> [Char]
Show, (forall a b. (a -> b) -> LogEntry a -> LogEntry b)
-> (forall a b. a -> LogEntry b -> LogEntry a) -> Functor LogEntry
forall a b. a -> LogEntry b -> LogEntry a
forall a b. (a -> b) -> LogEntry a -> LogEntry b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LogEntry a -> LogEntry b
fmap :: forall a b. (a -> b) -> LogEntry a -> LogEntry b
$c<$ :: forall a b. a -> LogEntry b -> LogEntry a
<$ :: forall a b. a -> LogEntry b -> LogEntry a
Functor)

newtype Chain log result = Chain
  {forall log result.
Chain log result -> Context -> [([LogEntry log], result)]
runChain :: Context -> [([LogEntry log], result)]}
  deriving ((forall a b. (a -> b) -> Chain log a -> Chain log b)
-> (forall a b. a -> Chain log b -> Chain log a)
-> Functor (Chain log)
forall a b. a -> Chain log b -> Chain log a
forall a b. (a -> b) -> Chain log a -> Chain log b
forall log a b. a -> Chain log b -> Chain log a
forall log a b. (a -> b) -> Chain log a -> Chain log b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall log a b. (a -> b) -> Chain log a -> Chain log b
fmap :: forall a b. (a -> b) -> Chain log a -> Chain log b
$c<$ :: forall log a b. a -> Chain log b -> Chain log a
<$ :: forall a b. a -> Chain log b -> Chain log a
Functor)

type NormalizeChain = Chain Object
type DataizeChain = Chain (Either Object Bytes)
instance Applicative (Chain a) where
  pure :: forall a. a -> Chain a a
pure a
x = (Context -> [([LogEntry a], a)]) -> Chain a a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ([([LogEntry a], a)] -> Context -> [([LogEntry a], a)]
forall a b. a -> b -> a
const [([], a
x)])
  <*> :: forall a b. Chain a (a -> b) -> Chain a a -> Chain a b
(<*>) = Chain a (a -> b) -> Chain a a -> Chain a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Chain a) where
  return :: forall a. a -> Chain a a
return = a -> Chain a a
forall a. a -> Chain a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Chain Context -> [([LogEntry a], a)]
dx >>= :: forall a b. Chain a a -> (a -> Chain a b) -> Chain a b
>>= a -> Chain a b
f = (Context -> [([LogEntry a], b)]) -> Chain a b
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry a], b)]) -> Chain a b)
-> (Context -> [([LogEntry a], b)]) -> Chain a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
    [ ([LogEntry a]
steps [LogEntry a] -> [LogEntry a] -> [LogEntry a]
forall a. Semigroup a => a -> a -> a
<> [LogEntry a]
steps', b
y)
    | ([LogEntry a]
steps, a
x) <- Context -> [([LogEntry a], a)]
dx Context
ctx
    , ([LogEntry a]
steps', b
y) <- Chain a b -> Context -> [([LogEntry a], b)]
forall log result.
Chain log result -> Context -> [([LogEntry log], result)]
runChain (a -> Chain a b
f a
x) Context
ctx
    ]

instance MonadFail (Chain a) where
  fail :: forall a. [Char] -> Chain a a
fail [Char]
_msg = (Context -> [([LogEntry a], a)]) -> Chain a a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ([([LogEntry a], a)] -> Context -> [([LogEntry a], a)]
forall a b. a -> b -> a
const [])

logStep :: String -> info -> Chain info ()
logStep :: forall info. [Char] -> info -> Chain info ()
logStep [Char]
msg info
info = (Context -> [([LogEntry info], ())]) -> Chain info ()
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry info], ())]) -> Chain info ())
-> (Context -> [([LogEntry info], ())]) -> Chain info ()
forall a b. (a -> b) -> a -> b
$ [([LogEntry info], ())] -> Context -> [([LogEntry info], ())]
forall a b. a -> b -> a
const [([[Char] -> info -> Int -> LogEntry info
forall log. [Char] -> log -> Int -> LogEntry log
LogEntry [Char]
msg info
info Int
0], ())]

incLogLevel :: Chain info a -> Chain info a
incLogLevel :: forall info a. Chain info a -> Chain info a
incLogLevel (Chain Context -> [([LogEntry info], a)]
k) =
  (Context -> [([LogEntry info], a)]) -> Chain info a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry info], a)]) -> Chain info a)
-> (Context -> [([LogEntry info], a)]) -> Chain info a
forall a b. (a -> b) -> a -> b
$
    (([LogEntry info], a) -> ([LogEntry info], a))
-> [([LogEntry info], a)] -> [([LogEntry info], a)]
forall a b. (a -> b) -> [a] -> [b]
map (([LogEntry info] -> [LogEntry info])
-> ([LogEntry info], a) -> ([LogEntry info], a)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((LogEntry info -> LogEntry info)
-> [LogEntry info] -> [LogEntry info]
forall a b. (a -> b) -> [a] -> [b]
map (\LogEntry{info
Int
[Char]
logEntryMessage :: forall log. LogEntry log -> [Char]
logEntryLog :: forall log. LogEntry log -> log
logEntryLevel :: forall log. LogEntry log -> Int
logEntryMessage :: [Char]
logEntryLog :: info
logEntryLevel :: Int
..} -> LogEntry{logEntryLevel :: Int
logEntryLevel = Int
logEntryLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, info
[Char]
logEntryMessage :: [Char]
logEntryLog :: info
logEntryMessage :: [Char]
logEntryLog :: info
..})))
      ([([LogEntry info], a)] -> [([LogEntry info], a)])
-> (Context -> [([LogEntry info], a)])
-> Context
-> [([LogEntry info], a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> [([LogEntry info], a)]
k

choose :: [a] -> Chain log a
choose :: forall a log. [a] -> Chain log a
choose [a]
xs = (Context -> [([LogEntry log], a)]) -> Chain log a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry log], a)]) -> Chain log a)
-> (Context -> [([LogEntry log], a)]) -> Chain log a
forall a b. (a -> b) -> a -> b
$ \Context
_ctx -> [([LogEntry log]
forall a. Monoid a => a
mempty, a
x) | a
x <- [a]
xs]

msplit :: Chain log a -> Chain log (Maybe (a, Chain log a))
msplit :: forall log a. Chain log a -> Chain log (Maybe (a, Chain log a))
msplit (Chain Context -> [([LogEntry log], a)]
m) = (Context -> [([LogEntry log], Maybe (a, Chain log a))])
-> Chain log (Maybe (a, Chain log a))
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry log], Maybe (a, Chain log a))])
 -> Chain log (Maybe (a, Chain log a)))
-> (Context -> [([LogEntry log], Maybe (a, Chain log a))])
-> Chain log (Maybe (a, Chain log a))
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
  case Context -> [([LogEntry log], a)]
m Context
ctx of
    [] -> Chain log (Maybe (a, Chain log a))
-> Context -> [([LogEntry log], Maybe (a, Chain log a))]
forall log result.
Chain log result -> Context -> [([LogEntry log], result)]
runChain (Maybe (a, Chain log a) -> Chain log (Maybe (a, Chain log a))
forall a. a -> Chain log a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, Chain log a)
forall a. Maybe a
Nothing) Context
ctx
    ([LogEntry log]
logs, a
x) : [([LogEntry log], a)]
xs -> [([LogEntry log]
logs, (a, Chain log a) -> Maybe (a, Chain log a)
forall a. a -> Maybe a
Just (a
x, (Context -> [([LogEntry log], a)]) -> Chain log a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ([([LogEntry log], a)] -> Context -> [([LogEntry log], a)]
forall a b. a -> b -> a
const [([LogEntry log], a)]
xs)))]

transformLogs :: (log1 -> log2) -> Chain log1 a -> Chain log2 a
transformLogs :: forall log1 log2 a. (log1 -> log2) -> Chain log1 a -> Chain log2 a
transformLogs log1 -> log2
f (Chain Context -> [([LogEntry log1], a)]
normChain) = (Context -> [([LogEntry log2], a)]) -> Chain log2 a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry log2], a)]) -> Chain log2 a)
-> (Context -> [([LogEntry log2], a)]) -> Chain log2 a
forall a b. (a -> b) -> a -> b
$ (([LogEntry log1], a) -> ([LogEntry log2], a))
-> [([LogEntry log1], a)] -> [([LogEntry log2], a)]
forall a b. (a -> b) -> [a] -> [b]
map (([LogEntry log1] -> [LogEntry log2])
-> ([LogEntry log1], a) -> ([LogEntry log2], a)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((LogEntry log1 -> LogEntry log2)
-> [LogEntry log1] -> [LogEntry log2]
forall a b. (a -> b) -> [a] -> [b]
map ((log1 -> log2) -> LogEntry log1 -> LogEntry log2
forall a b. (a -> b) -> LogEntry a -> LogEntry b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap log1 -> log2
f))) ([([LogEntry log1], a)] -> [([LogEntry log2], a)])
-> (Context -> [([LogEntry log1], a)])
-> Context
-> [([LogEntry log2], a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> [([LogEntry log1], a)]
normChain

transformNormLogs :: NormalizeChain a -> DataizeChain a
transformNormLogs :: forall a. NormalizeChain a -> DataizeChain a
transformNormLogs = (Object -> Either Object Bytes)
-> Chain Object a -> Chain (Either Object Bytes) a
forall log1 log2 a. (log1 -> log2) -> Chain log1 a -> Chain log2 a
transformLogs Object -> Either Object Bytes
forall a b. a -> Either a b
Left

listen :: Chain log a -> Chain log (a, [LogEntry log])
listen :: forall log a. Chain log a -> Chain log (a, [LogEntry log])
listen (Chain Context -> [([LogEntry log], a)]
k) = (Context -> [([LogEntry log], (a, [LogEntry log]))])
-> Chain log (a, [LogEntry log])
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((([LogEntry log], a) -> ([LogEntry log], (a, [LogEntry log])))
-> [([LogEntry log], a)] -> [([LogEntry log], (a, [LogEntry log]))]
forall a b. (a -> b) -> [a] -> [b]
map (\([LogEntry log]
logs, a
result) -> ([LogEntry log]
logs, (a
result, [LogEntry log]
logs))) ([([LogEntry log], a)] -> [([LogEntry log], (a, [LogEntry log]))])
-> (Context -> [([LogEntry log], a)])
-> Context
-> [([LogEntry log], (a, [LogEntry log]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> [([LogEntry log], a)]
k)

minimizeObject' :: DataizeChain (Either Object Bytes) -> DataizeChain (Either Object Bytes)
minimizeObject' :: DataizeChain (Either Object Bytes)
-> DataizeChain (Either Object Bytes)
minimizeObject' DataizeChain (Either Object Bytes)
m = do
  (Context -> Bool)
-> Chain (Either Object Bytes) Context
-> Chain (Either Object Bytes) Bool
forall a b.
(a -> b)
-> Chain (Either Object Bytes) a -> Chain (Either Object Bytes) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context -> Bool
minimizeTerms Chain (Either Object Bytes) Context
forall a. Chain a Context
getContext Chain (Either Object Bytes) Bool
-> (Bool -> DataizeChain (Either Object Bytes))
-> DataizeChain (Either Object Bytes)
forall a b.
Chain (Either Object Bytes) a
-> (a -> Chain (Either Object Bytes) b)
-> Chain (Either Object Bytes) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> DataizeChain (Either Object Bytes)
-> DataizeChain (Either Object Bytes)
minimizeObject DataizeChain (Either Object Bytes)
m
    Bool
False -> DataizeChain (Either Object Bytes)
m

minimizeObject :: DataizeChain (Either Object Bytes) -> DataizeChain (Either Object Bytes)
minimizeObject :: DataizeChain (Either Object Bytes)
-> DataizeChain (Either Object Bytes)
minimizeObject DataizeChain (Either Object Bytes)
m = do
  (Either Object Bytes
x, [LogEntry (Either Object Bytes)]
entries) <- DataizeChain (Either Object Bytes)
-> Chain
     (Either Object Bytes)
     (Either Object Bytes, [LogEntry (Either Object Bytes)])
forall log a. Chain log a -> Chain log (a, [LogEntry log])
listen DataizeChain (Either Object Bytes)
m
  case Either Object Bytes
x of
    Left Object
obj' -> do
      let objectsOnCurrentLevel :: [Either Object Bytes]
objectsOnCurrentLevel =
            [Either Object Bytes
logEntryLog | LogEntry{Int
[Char]
Either Object Bytes
logEntryMessage :: forall log. LogEntry log -> [Char]
logEntryLog :: forall log. LogEntry log -> log
logEntryLevel :: forall log. LogEntry log -> Int
logEntryLog :: Either Object Bytes
logEntryMessage :: [Char]
logEntryLevel :: Int
..} <- [LogEntry (Either Object Bytes)]
entries, Int
logEntryLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
      Either Object Bytes -> DataizeChain (Either Object Bytes)
forall a. a -> Chain (Either Object Bytes) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Either Object Bytes
forall a b. a -> Either a b
Left ([Either Object Bytes] -> Object -> Object
forall bytes. [Either Object bytes] -> Object -> Object
smallestObject [Either Object Bytes]
objectsOnCurrentLevel Object
obj'))
    Right Bytes
_ -> Either Object Bytes -> DataizeChain (Either Object Bytes)
forall a. a -> Chain (Either Object Bytes) a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Object Bytes
x

smallestObject :: [Either Object bytes] -> Object -> Object
smallestObject :: forall bytes. [Either Object bytes] -> Object -> Object
smallestObject [Either Object bytes]
objs Object
obj = (Object -> Object -> Ordering) -> [Object] -> Object
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Object -> Int) -> Object -> Object -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Object -> Int
objectSize) (Object
obj Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [Either Object bytes] -> [Object]
forall {a} {b}. [Either a b] -> [a]
lefts [Either Object bytes]
objs)
 where
  lefts :: [Either a b] -> [a]
lefts [] = []
  lefts (Left a
x : [Either a b]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Either a b] -> [a]
lefts [Either a b]
xs
  lefts (Right{} : [Either a b]
xs) = [Either a b] -> [a]
lefts [Either a b]
xs

getContext :: Chain a Context
getContext :: forall a. Chain a Context
getContext = (Context -> [([LogEntry a], Context)]) -> Chain a Context
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain ((Context -> [([LogEntry a], Context)]) -> Chain a Context)
-> (Context -> [([LogEntry a], Context)]) -> Chain a Context
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> [([], Context
ctx)]

withContext :: Context -> Chain log a -> Chain log a
withContext :: forall log a. Context -> Chain log a -> Chain log a
withContext = (Context -> Context) -> Chain log a -> Chain log a
forall log a. (Context -> Context) -> Chain log a -> Chain log a
modifyContext ((Context -> Context) -> Chain log a -> Chain log a)
-> (Context -> Context -> Context)
-> Context
-> Chain log a
-> Chain log a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context -> Context
forall a b. a -> b -> a
const

modifyContext :: (Context -> Context) -> Chain log a -> Chain log a
modifyContext :: forall log a. (Context -> Context) -> Chain log a -> Chain log a
modifyContext Context -> Context
g (Chain Context -> [([LogEntry log], a)]
f) = (Context -> [([LogEntry log], a)]) -> Chain log a
forall log result.
(Context -> [([LogEntry log], result)]) -> Chain log result
Chain (Context -> [([LogEntry log], a)]
f (Context -> [([LogEntry log], a)])
-> (Context -> Context) -> Context -> [([LogEntry log], a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
g)

applyRulesChain' :: Context -> Object -> [([LogEntry Object], Object)]
applyRulesChain' :: Context -> Object -> [([LogEntry Object], Object)]
applyRulesChain' Context
ctx Object
obj = ApplicationLimits
-> Context -> Object -> [([LogEntry Object], Object)]
applyRulesChainWith' (Int -> ApplicationLimits
defaultApplicationLimits (Object -> Int
objectSize Object
obj)) Context
ctx Object
obj

-- | Apply the rules until the object is normalized, preserving the history (chain) of applications.
applyRulesChain :: Object -> NormalizeChain Object
applyRulesChain :: Object -> NormalizeChain Object
applyRulesChain Object
obj = ApplicationLimits -> Object -> NormalizeChain Object
applyRulesChainWith (Int -> ApplicationLimits
defaultApplicationLimits (Object -> Int
objectSize Object
obj)) Object
obj

applyRulesChainWith' :: ApplicationLimits -> Context -> Object -> [([LogEntry Object], Object)]
applyRulesChainWith' :: ApplicationLimits
-> Context -> Object -> [([LogEntry Object], Object)]
applyRulesChainWith' ApplicationLimits
limits Context
ctx Object
obj = NormalizeChain Object -> Context -> [([LogEntry Object], Object)]
forall log result.
Chain log result -> Context -> [([LogEntry log], result)]
runChain (ApplicationLimits -> Object -> NormalizeChain Object
applyRulesChainWith ApplicationLimits
limits Object
obj) Context
ctx

-- | A variant of `applyRulesChain` with a maximum application depth.
applyRulesChainWith :: ApplicationLimits -> Object -> NormalizeChain Object
applyRulesChainWith :: ApplicationLimits -> Object -> NormalizeChain Object
applyRulesChainWith limits :: ApplicationLimits
limits@ApplicationLimits{Int
maxDepth :: ApplicationLimits -> Int
maxTermSize :: ApplicationLimits -> Int
maxDepth :: Int
maxTermSize :: Int
..} Object
obj
  | Int
maxDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = do
      [Char] -> Object -> Chain Object ()
forall info. [Char] -> info -> Chain info ()
logStep [Char]
"Max depth hit" Object
obj
      Object -> NormalizeChain Object
forall a. a -> Chain Object a
forall (m :: * -> *) a. Monad m => a -> m a
return Object
obj
  | Bool
otherwise = do
      Context
ctx <- Chain Object Context
forall a. Chain a Context
getContext
      if Context -> Object -> Bool
isNF Context
ctx Object
obj
        then do
          [Char] -> Object -> Chain Object ()
forall info. [Char] -> info -> Chain info ()
logStep [Char]
"NF" Object
obj
          Object -> NormalizeChain Object
forall a. a -> Chain Object a
forall (m :: * -> *) a. Monad m => a -> m a
return Object
obj
        else do
          ([Char]
ruleName, Object
obj') <- [([Char], Object)] -> Chain Object ([Char], Object)
forall a log. [a] -> Chain log a
choose (Context -> Object -> [([Char], Object)]
applyOneRule Context
ctx Object
obj)
          [Char] -> Object -> Chain Object ()
forall info. [Char] -> info -> Chain info ()
logStep [Char]
ruleName Object
obj'
          if Object -> Int
objectSize Object
obj' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxTermSize
            then ApplicationLimits -> Object -> NormalizeChain Object
applyRulesChainWith ApplicationLimits
limits{maxDepth = maxDepth - 1} Object
obj'
            else do
              [Char] -> Object -> Chain Object ()
forall info. [Char] -> info -> Chain info ()
logStep [Char]
"Max term size hit" Object
obj'
              Object -> NormalizeChain Object
forall a. a -> Chain Object a
forall (m :: * -> *) a. Monad m => a -> m a
return Object
obj'

-- * Helpers

-- | Lookup a binding by the attribute name.
lookupBinding :: Attribute -> [Binding] -> Maybe Object
lookupBinding :: Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
_ [] = Maybe Object
forall a. Maybe a
Nothing
lookupBinding Attribute
a (AlphaBinding' Attribute
a' Object
object : [Binding]
bindings)
  | Attribute
a Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
a' = Object -> Maybe Object
forall a. a -> Maybe a
Just Object
object
  | Bool
otherwise = Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
a [Binding]
bindings
lookupBinding Attribute
_ (b :: Binding
b@(AlphaBinding''{}) : [Binding]
_) = Binding -> Maybe Object
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
b
lookupBinding Attribute
a (Binding
_ : [Binding]
bindings) = Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
a [Binding]
bindings

objectBindings :: Object -> [Binding]
objectBindings :: Object -> [Binding]
objectBindings (Formation [Binding]
bs) = [Binding]
bs
objectBindings (Application Object
obj [Binding]
bs) = Object -> [Binding]
objectBindings Object
obj [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
bs
objectBindings (ObjectDispatch Object
obj Attribute
_attr) = Object -> [Binding]
objectBindings Object
obj
objectBindings Object
_ = []

isRhoBinding :: Binding -> Bool
isRhoBinding :: Binding -> Bool
isRhoBinding (AlphaBinding' Attribute
Rho Object
_) = Bool
True
isRhoBinding Binding
_ = Bool
False

hideRhoInBinding :: Binding -> Binding
hideRhoInBinding :: Binding -> Binding
hideRhoInBinding = \case
  AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
hideRho Object
obj)
  Binding
binding -> Binding
binding

hideRho :: Object -> Object
hideRho :: Object -> Object
hideRho = \case
  Formation [Binding]
bindings ->
    [Binding] -> Object
Formation
      [ Binding -> Binding
hideRhoInBinding Binding
binding
      | Binding
binding <- (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Binding -> Bool) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Bool
isRhoBinding) [Binding]
bindings
      ]
  Application Object
obj [Binding]
bindings ->
    Object -> [Binding] -> Object
Application
      (Object -> Object
hideRho Object
obj)
      [ Binding -> Binding
hideRhoInBinding Binding
binding
      | Binding
binding <- (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Binding -> Bool) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Bool
isRhoBinding) [Binding]
bindings
      ]
  ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Object -> Object
hideRho Object
obj) Attribute
a
  Object
obj -> Object
obj

hideRhoInBinding1 :: Binding -> Binding
hideRhoInBinding1 :: Binding -> Binding
hideRhoInBinding1 = \case
  AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
hideRho Object
obj)
  Binding
binding -> Binding
binding

hideRho1 :: Object -> Object
hideRho1 :: Object -> Object
hideRho1 = \case
  Formation [Binding]
bindings ->
    [Binding] -> Object
Formation
      [ Binding -> Binding
hideRhoInBinding1 Binding
binding
      | Binding
binding <- [Binding]
bindings
      ]
  Application Object
obj [Binding]
bindings ->
    Object -> [Binding] -> Object
Application
      (Object -> Object
hideRho1 Object
obj)
      [ Binding -> Binding
hideRhoInBinding1 Binding
binding
      | Binding
binding <- [Binding]
bindings
      ]
  ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Object -> Object
hideRho1 Object
obj) Attribute
a
  Object
obj -> Object
obj