{- 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 RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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.ByteString (ByteString)
import Data.ByteString qualified as ByteString.Strict
import Data.Char (toUpper)
import Data.HashMap.Strict qualified as HashMap
import Data.List (intercalate, minimumBy, nubBy, sortOn)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.Ord (comparing)
import Data.Serialize qualified as Serialize
import Data.String (IsString (..))
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Language.EO.Phi.Syntax.Abs
import Language.EO.Phi.Syntax.Lex (Token)
import Language.EO.Phi.Syntax.Par
import Numeric (readHex, showHex)

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

instance IsString Program where fromString :: [Char] -> Program
fromString = ([Token] -> Either [Char] Program) -> [Char] -> Program
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Program
pProgram
instance IsString Object where fromString :: [Char] -> Object
fromString = ([Token] -> Either [Char] Object) -> [Char] -> Object
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Object
pObject
instance IsString Binding where fromString :: [Char] -> Binding
fromString = ([Token] -> Either [Char] Binding) -> [Char] -> Binding
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Binding
pBinding
instance IsString Attribute where fromString :: [Char] -> Attribute
fromString = ([Token] -> Either [Char] Attribute) -> [Char] -> Attribute
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Attribute
pAttribute
instance IsString RuleAttribute where fromString :: [Char] -> RuleAttribute
fromString = ([Token] -> Either [Char] RuleAttribute) -> [Char] -> RuleAttribute
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] RuleAttribute
pRuleAttribute
instance IsString PeeledObject where fromString :: [Char] -> PeeledObject
fromString = ([Token] -> Either [Char] PeeledObject) -> [Char] -> PeeledObject
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] PeeledObject
pPeeledObject
instance IsString ObjectHead where fromString :: [Char] -> ObjectHead
fromString = ([Token] -> Either [Char] ObjectHead) -> [Char] -> ObjectHead
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] ObjectHead
pObjectHead

instance IsString MetaId where fromString :: [Char] -> MetaId
fromString = ([Token] -> Either [Char] MetaId) -> [Char] -> MetaId
forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] MetaId
pMetaId

parseWith :: ([Token] -> Either String a) -> String -> Either String a
parseWith :: forall a. ([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
parseWith [Token] -> Either [Char] a
parser [Char]
input = [Token] -> Either [Char] a
parser [Token]
tokens
 where
  tokens :: [Token]
tokens = [Char] -> [Token]
myLexer [Char]
input

-- | Parse a 'Object' from a 'String'.
-- May throw an 'error` if input has a syntactical or lexical errors.
unsafeParseWith :: ([Token] -> Either String a) -> String -> a
unsafeParseWith :: forall a. ([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] a
parser [Char]
input =
  case ([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a. ([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
parseWith [Token] -> Either [Char] a
parser [Char]
input of
    Left [Char]
parseError -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
parseError [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\non input\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
input [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n")
    Right a
object -> a
object

-- | 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
<|> case Object
root of
      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{} -> []
      ThisObject{} -> []
      Object
Termination -> []
      MetaObject ObjectMetaId
_ -> []
      MetaFunction MetaFunctionName
_ Object
_ -> []
      MetaTailContext{} -> []
      MetaSubstThis Object
_ Object
_ -> []
      MetaContextualize Object
_ Object
_ -> []
 where
  subctx :: Context
subctx = Context
ctx{insideSubObject = True}

-- | 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
  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
  Object
ThisObject -> Int
1
  Object
Termination -> Int
1
  MetaObject{} -> Int
1 -- should be impossible
  MetaFunction{} -> Int
1 -- should be impossible
  MetaSubstThis{} -> Int
1 -- should be impossible
  MetaContextualize{} -> Int
1 -- should be impossible
  MetaTailContext{} -> Int
1 -- should be impossible

bindingSize :: Binding -> Int
bindingSize :: Binding -> Int
bindingSize = \case
  AlphaBinding Attribute
_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
  MetaDeltaBinding{} -> Int
1 -- should be impossible
  MetaBindings{} -> Int
1 -- should be impossible

-- | 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 (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)

equalBinding :: Binding -> Binding -> Bool
equalBinding :: Binding -> Binding -> Bool
equalBinding (AlphaBinding Attribute
attr1 Object
obj1) (AlphaBinding Attribute
attr2 Object
obj2) = Attribute
attr1 Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
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]
"Normal form" 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
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
_ = []

padLeft :: Int -> [Char] -> [Char]
padLeft :: Int -> [Char] -> [Char]
padLeft Int
n [Char]
s = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

-- | Split a list into chunks of given size.
-- All lists in the result are guaranteed to have length less than or equal to the given size.
--
-- >>> chunksOf 2 "012345678"
-- ["01","23","45","67","8"]
--
-- See 'paddedLeftChunksOf' for a version with padding to guarantee exact chunk size.
chunksOf :: Int -> [a] -> [[a]]
chunksOf :: forall a. Int -> [a] -> [[a]]
chunksOf Int
_ [] = []
chunksOf Int
n [a]
xs = [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n [a]
leftover
 where
  ([a]
chunk, [a]
leftover) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs

-- | Split a list into chunks of given size,
-- padding on the left if necessary.
-- All lists in the result are guaranteed to have given size.
--
-- >>> paddedLeftChunksOf '0' 2 "1234567"
-- ["01","23","45","67"]
-- >>> paddedLeftChunksOf '0' 2 "123456"
-- ["12","34","56"]
--
-- prop> n > 0  ==>  all (\chunk -> length chunk == n) (paddedLeftChunksOf c n s)
paddedLeftChunksOf :: a -> Int -> [a] -> [[a]]
paddedLeftChunksOf :: forall a. a -> Int -> [a] -> [[a]]
paddedLeftChunksOf a
padSymbol Int
n [a]
xs
  | Int
padSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n [a]
xs
  | Bool
otherwise = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
padSize a
padSymbol [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs)
 where
  len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  padSize :: Int
padSize = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n

-- | Normalize the bytestring representation to fit valid 'Bytes' token.
--
-- >>> normalizeBytes "238714ABCDEF"
-- "23-87-14-AB-CD-EF"
--
-- >>> normalizeBytes "0238714ABCDEF"
-- "00-23-87-14-AB-CD-EF"
--
-- >>> normalizeBytes "4"
-- "04-"
normalizeBytes :: String -> String
normalizeBytes :: [Char] -> [Char]
normalizeBytes = [[Char]] -> [Char]
withDashes ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int -> [Char] -> [[Char]]
forall a. a -> Int -> [a] -> [[a]]
paddedLeftChunksOf Char
'0' Int
2 ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper
 where
  withDashes :: [[Char]] -> [Char]
withDashes = \case
    [] -> [Char]
"00-"
    [[Char]
byte] -> [Char]
byte [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-"
    [[Char]]
bytes -> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" [[Char]]
bytes

-- | Concatenate 'Bytes'.
-- FIXME: we should really use 'ByteString' instead of the underlying 'String' representation.
--
-- >>> concatBytes "00-" "01-02"
-- Bytes "00-01-02"
--
-- >>> concatBytes "03-04" "01-02"
-- Bytes "03-04-01-02"
--
-- >>> concatBytes "03-04" "01-"
-- Bytes "03-04-01"
concatBytes :: Bytes -> Bytes -> Bytes
concatBytes :: Bytes -> Bytes -> Bytes
concatBytes (Bytes [Char]
xs) (Bytes [Char]
zs) = [Char] -> Bytes
Bytes ([Char] -> [Char]
normalizeBytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') ([Char]
xs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
zs)))

-- | Select a slice (section) of 'Bytes'.
--
-- >>> sliceBytes "12-34-56" 1 1
-- Bytes "34-"
--
-- >>> sliceBytes "12-34-56" 1 0
-- Bytes "00-"
--
-- >>> sliceBytes "12-34-56" 0 2
-- Bytes "12-34"
sliceBytes :: Bytes -> Int -> Int -> Bytes
sliceBytes :: Bytes -> Int -> Int -> Bytes
sliceBytes (Bytes [Char]
bytes) Int
start Int
len = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
len) (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
start) ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
bytes))

-- | Convert an 'Int' into 'Bytes' representation.
--
-- >>> intToBytes 7
-- Bytes "00-00-00-00-00-00-00-07"
-- >>> intToBytes (3^33)
-- Bytes "00-13-BF-EF-A6-5A-BB-83"
-- >>> intToBytes (-1)
-- Bytes "FF-FF-FF-FF-FF-FF-FF-FF"
intToBytes :: Int -> Bytes
intToBytes :: Int -> Bytes
intToBytes Int
n = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Int
n

-- | Parse 'Bytes' as 'Int'.
--
-- >>> bytesToInt "00-13-BF-EF-A6-5A-BB-83"
-- 5559060566555523
-- >>> bytesToInt "AB-"
-- 171
--
-- May error on invalid 'Bytes':
--
-- >>> bytesToInt "s"
-- *** Exception: Prelude.head: empty list
-- ...
-- ...
-- ...
-- ...
-- ...
-- ...
bytesToInt :: Bytes -> Int
bytesToInt :: Bytes -> Int
bytesToInt (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [Char]
bytes))
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
bytes = Int
0
  | Bool
otherwise = (Int, [Char]) -> Int
forall a b. (a, b) -> a
fst ((Int, [Char]) -> Int) -> (Int, [Char]) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, [Char])] -> (Int, [Char])
forall a. HasCallStack => [a] -> a
head ([(Int, [Char])] -> (Int, [Char]))
-> [(Int, [Char])] -> (Int, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
bytes

-- | Convert 'Bool' to 'Bytes'.
--
-- >>> boolToBytes False
-- Bytes "00-"
-- >>> boolToBytes True
-- Bytes "01-"
boolToBytes :: Bool -> Bytes
boolToBytes :: Bool -> Bytes
boolToBytes Bool
True = [Char] -> Bytes
Bytes [Char]
"01-"
boolToBytes Bool
False = [Char] -> Bytes
Bytes [Char]
"00-"

-- | Interpret 'Bytes' as 'Bool'.
--
-- Zero is interpreted as 'False'.
--
-- >>> bytesToBool "00-"
-- False
--
-- >>> bytesToBool "00-00"
-- False
--
-- Everything else is interpreted as 'True'.
--
-- >>> bytesToBool "01-"
-- True
--
-- >>> bytesToBool "00-01"
-- True
--
-- >>> bytesToBool "AB-CD"
-- True
bytesToBool :: Bytes -> Bool
bytesToBool :: Bytes -> Bool
bytesToBool (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [])) = Bool
False
bytesToBool Bytes
_ = Bool
True

-- | Encode 'String' as 'Bytes'.
--
-- >>> stringToBytes "Hello, world!"
-- Bytes "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21"
--
-- >>> stringToBytes "Привет, мир!"
-- Bytes "D0-9F-D1-80-D0-B8-D0-B2-D0-B5-D1-82-2C-20-D0-BC-D0-B8-D1-80-21"
--
-- >>> stringToBytes  "hello, 大家!"
-- Bytes "68-65-6C-6C-6F-2C-20-E5-A4-A7-E5-AE-B6-21"
stringToBytes :: String -> Bytes
stringToBytes :: [Char] -> Bytes
stringToBytes [Char]
s = ByteString -> Bytes
bytestringToBytes (ByteString -> Bytes) -> ByteString -> Bytes
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 ([Char] -> Text
Text.pack [Char]
s)

bytestringToBytes :: ByteString -> Bytes
bytestringToBytes :: ByteString -> Bytes
bytestringToBytes = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> (ByteString -> [Char]) -> ByteString -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
normalizeBytes ([Char] -> [Char])
-> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char])
-> (ByteString -> [Word8]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
ByteString.Strict.unpack

bytesToByteString :: Bytes -> ByteString
bytesToByteString :: Bytes -> ByteString
bytesToByteString (Bytes [Char]
bytes) = [Word8] -> ByteString
ByteString.Strict.pack ([Char] -> [Word8]
forall {a}. (Eq a, Num a) => [Char] -> [a]
go ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
bytes))
 where
  go :: [Char] -> [a]
go [] = []
  go (Char
x : Char
y : [Char]
xs) = (a, [Char]) -> a
forall a b. (a, b) -> a
fst ([(a, [Char])] -> (a, [Char])
forall a. HasCallStack => [a] -> a
head (ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex [Char
x, Char
y])) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Char] -> [a]
go [Char]
xs
  go [Char
_] = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: partial byte"

-- | Decode 'String' from 'Bytes'.
--
-- >>> bytesToString "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21"
-- "Hello, world!"
bytesToString :: Bytes -> String
bytesToString :: Bytes -> [Char]
bytesToString = Text -> [Char]
Text.unpack (Text -> [Char]) -> (Bytes -> Text) -> Bytes -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (Bytes -> ByteString) -> Bytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
bytesToByteString

-- | Encode 'Double' as 'Bytes' following IEEE754.
--
-- Note: it is called "float" in EO, but it actually occupies 8 bytes so it corresponds to 'Double'.
--
-- >>> floatToBytes 0
-- Bytes "00-00-00-00-00-00-00-00"
--
-- >>> floatToBytes (-0.1)
-- Bytes "BF-B9-99-99-99-99-99-9A"
--
-- >>> floatToBytes (1/0)       -- Infinity
-- Bytes "7F-F0-00-00-00-00-00-00"
--
-- >>> floatToBytes (asin 2) `elem` ["FF-F8-00-00-00-00-00-00", "7F-F8-00-00-00-00-00-00"]  -- sNaN or qNaN
-- True
floatToBytes :: Double -> Bytes
floatToBytes :: Double -> Bytes
floatToBytes Double
f = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Double -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Double
f

-- | Decode 'Double' from 'Bytes' following IEEE754.
--
-- >>> bytesToFloat "00-00-00-00-00-00-00-00"
-- 0.0
--
-- >>> bytesToFloat "BF-B9-99-99-99-99-99-9A"
-- -0.1
--
-- >>> bytesToFloat "7F-F0-00-00-00-00-00-00"
-- Infinity
--
-- >>> bytesToFloat "FF-F8-00-00-00-00-00-00"
-- NaN
bytesToFloat :: Bytes -> Double
bytesToFloat :: Bytes -> Double
bytesToFloat (Bytes [Char]
bytes) =
  case ByteString -> Either [Char] Double
forall a. Serialize a => ByteString -> Either [Char] a
Serialize.decode (ByteString -> Either [Char] Double)
-> ByteString -> Either [Char] Double
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
ByteString.Strict.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ ([Char] -> Word8) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8, [Char]) -> Word8
forall a b. (a, b) -> a
fst ((Word8, [Char]) -> Word8)
-> ([Char] -> (Word8, [Char])) -> [Char] -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word8, [Char])] -> (Word8, [Char])
forall a. HasCallStack => [a] -> a
head ([(Word8, [Char])] -> (Word8, [Char]))
-> ([Char] -> [(Word8, [Char])]) -> [Char] -> (Word8, [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(Word8, [Char])]
forall a. (Eq a, Num a) => ReadS a
readHex) ([[Char]] -> [Word8]) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
dashToSpace [Char]
bytes) of
    Left [Char]
msg -> [Char] -> Double
forall a. HasCallStack => [Char] -> a
error [Char]
msg
    Right Double
x -> Double
x
 where
  dashToSpace :: Char -> Char
dashToSpace Char
'-' = Char
' '
  dashToSpace Char
c = Char
c

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 Attribute
a Object
obj -> Attribute -> Object -> Binding
AlphaBinding Attribute
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 Attribute
a Object
obj -> Attribute -> Object -> Binding
AlphaBinding Attribute
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