{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

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

module AST
  ( Slot (..)
  , Expression (ExFormation, ExXi, ExRoot, ExTermination, ExApplication, ExDispatch, ExMeta, ExAny, ExPhiMeet, ExPhiAgain, ExBytes)
  , Argument (..)
  , Alpha (..)
  , Binding (..)
  , Bytes (..)
  , Attribute (..)
  , Function (..)
  , hashExpression
  , hashShape
  , hashSkeleton
  , inert
  , distinct
  , repeated
  , attributeFromBinding
  , alike
  , within
  , symbols
  , lifted
  , denoted
  , countNodes
  , matchBaseObject
  , pattern BaseObject
  , matchDataObject
  , pattern DataString
  , pattern DataNumber
  , pattern DataObject
  , dataBytes
  )
where

import Data.Bits (xor)
import qualified Data.IntMap.Strict as IntMap
import Data.List (foldl')
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)
import GHC.Generics (Generic)

data Slot = Slot Text Int
  deriving (Slot -> Slot -> Bool
(Slot -> Slot -> Bool) -> (Slot -> Slot -> Bool) -> Eq Slot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Slot -> Slot -> Bool
== :: Slot -> Slot -> Bool
$c/= :: Slot -> Slot -> Bool
/= :: Slot -> Slot -> Bool
Eq, Eq Slot
Eq Slot =>
(Slot -> Slot -> Ordering)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Slot)
-> (Slot -> Slot -> Slot)
-> Ord Slot
Slot -> Slot -> Bool
Slot -> Slot -> Ordering
Slot -> Slot -> Slot
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Slot -> Slot -> Ordering
compare :: Slot -> Slot -> Ordering
$c< :: Slot -> Slot -> Bool
< :: Slot -> Slot -> Bool
$c<= :: Slot -> Slot -> Bool
<= :: Slot -> Slot -> Bool
$c> :: Slot -> Slot -> Bool
> :: Slot -> Slot -> Bool
$c>= :: Slot -> Slot -> Bool
>= :: Slot -> Slot -> Bool
$cmax :: Slot -> Slot -> Slot
max :: Slot -> Slot -> Slot
$cmin :: Slot -> Slot -> Slot
min :: Slot -> Slot -> Slot
Ord, Int -> Slot -> ShowS
[Slot] -> ShowS
Slot -> String
(Int -> Slot -> ShowS)
-> (Slot -> String) -> ([Slot] -> ShowS) -> Show Slot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Slot -> ShowS
showsPrec :: Int -> Slot -> ShowS
$cshow :: Slot -> String
show :: Slot -> String
$cshowList :: [Slot] -> ShowS
showList :: [Slot] -> ShowS
Show)

data Expression
  = Formed Facts [Binding]
  | ExXi
  | ExRoot
  | ExTermination
  | Applied Facts Expression Argument
  | Dispatched Facts Expression Attribute
  | ExMeta Text
  | ExAny Slot
  | ExPhiMeet (Maybe String) Int Expression
  | ExPhiAgain (Maybe String) Int Expression
  | ExBytes Bytes

data Facts = Facts !Int Int !Bool Bool

{-# COMPLETE ExFormation, ExXi, ExRoot, ExTermination, ExApplication, ExDispatch, ExMeta, ExAny, ExPhiMeet, ExPhiAgain, ExBytes #-}

pattern ExFormation :: [Binding] -> Expression
pattern $mExFormation :: forall {r}. Expression -> ([Binding] -> r) -> ((# #) -> r) -> r
$bExFormation :: [Binding] -> Expression
ExFormation bds <- Formed _ bds
  where
    ExFormation [Binding]
bds = (Facts -> Expression) -> Expression
cached (Facts -> [Binding] -> Expression
`Formed` [Binding]
bds)

pattern ExApplication :: Expression -> Argument -> Expression
pattern $mExApplication :: forall {r}.
Expression -> (Expression -> Argument -> r) -> ((# #) -> r) -> r
$bExApplication :: Expression -> Argument -> Expression
ExApplication expr arg <- Applied _ expr arg
  where
    ExApplication Expression
expr Argument
arg = (Facts -> Expression) -> Expression
cached (\Facts
facts -> Facts -> Expression -> Argument -> Expression
Applied Facts
facts Expression
expr Argument
arg)

pattern ExDispatch :: Expression -> Attribute -> Expression
pattern $mExDispatch :: forall {r}.
Expression -> (Expression -> Attribute -> r) -> ((# #) -> r) -> r
$bExDispatch :: Expression -> Attribute -> Expression
ExDispatch expr attr <- Dispatched _ expr attr
  where
    ExDispatch Expression
expr Attribute
attr = (Facts -> Expression) -> Expression
cached (\Facts
facts -> Facts -> Expression -> Attribute -> Expression
Dispatched Facts
facts Expression
expr Attribute
attr)

cached :: (Facts -> Expression) -> Expression
cached :: (Facts -> Expression) -> Expression
cached Facts -> Expression
node = let term :: Expression
term = Facts -> Expression
node (Expression -> Facts
established Expression
term) in Expression
term

known :: Expression -> Facts
known :: Expression -> Facts
known (Formed Facts
facts [Binding]
_) = Facts
facts
known (Applied Facts
facts Expression
_ Argument
_) = Facts
facts
known (Dispatched Facts
facts Expression
_ Attribute
_) = Facts
facts
known Expression
term = Expression -> Facts
established Expression
term

established :: Expression -> Facts
established :: Expression -> Facts
established Expression
term = Int -> Int -> Bool -> Bool -> Facts
Facts ((Int -> Int) -> (Expression -> Int) -> Expression -> Int
layer Int -> Int
forall a. a -> a
id Expression -> Int
hashExpression Expression
term) (Expression -> Int
tally Expression
term) (Expression -> Bool
calm Expression
term) (Expression -> Bool
unrepeated Expression
term)

instance Eq Expression where
  Expression
left == :: Expression -> Expression -> Bool
== Expression
right = Int# -> Bool
isTrue# (Expression -> Expression -> Int#
forall a b. a -> b -> Int#
reallyUnsafePtrEquality# Expression
left Expression
right) Bool -> Bool -> Bool
|| Expression -> Expression -> Bool
congruent Expression
left Expression
right
    where
      congruent :: Expression -> Expression -> Bool
      congruent :: Expression -> Expression -> Bool
congruent (Formed Facts
facts [Binding]
bds) (Formed Facts
facts' [Binding]
bds') = Facts -> Facts -> Bool
alongside Facts
facts Facts
facts' Bool -> Bool -> Bool
&& [Binding]
bds [Binding] -> [Binding] -> Bool
forall a. Eq a => a -> a -> Bool
== [Binding]
bds'
      congruent (Applied Facts
facts Expression
expr Argument
arg) (Applied Facts
facts' Expression
expr' Argument
arg') = Facts -> Facts -> Bool
alongside Facts
facts Facts
facts' Bool -> Bool -> Bool
&& Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr' Bool -> Bool -> Bool
&& Argument
arg Argument -> Argument -> Bool
forall a. Eq a => a -> a -> Bool
== Argument
arg'
      congruent (Dispatched Facts
facts Expression
expr Attribute
attr) (Dispatched Facts
facts' Expression
expr' Attribute
attr') = Facts -> Facts -> Bool
alongside Facts
facts Facts
facts' Bool -> Bool -> Bool
&& Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' Bool -> Bool -> Bool
&& Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr'
      congruent Expression
ExXi Expression
ExXi = Bool
True
      congruent Expression
ExRoot Expression
ExRoot = Bool
True
      congruent Expression
ExTermination Expression
ExTermination = Bool
True
      congruent (ExMeta Text
meta) (ExMeta Text
meta') = Text
meta Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
meta'
      congruent (ExAny Slot
slot) (ExAny Slot
slot') = Slot
slot Slot -> Slot -> Bool
forall a. Eq a => a -> a -> Bool
== Slot
slot'
      congruent (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) (ExPhiMeet Maybe String
prefix' Int
idx' Expression
expr') = Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' Bool -> Bool -> Bool
&& Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr'
      congruent (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) (ExPhiAgain Maybe String
prefix' Int
idx' Expression
expr') = Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' Bool -> Bool -> Bool
&& Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr'
      congruent (ExBytes Bytes
bts) (ExBytes Bytes
bts') = Bytes
bts Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
bts'
      congruent Expression
_ Expression
_ = Bool
False
      alongside :: Facts -> Facts -> Bool
      alongside :: Facts -> Facts -> Bool
alongside (Facts Int
digest Int
_ Bool
_ Bool
_) (Facts Int
digest' Int
_ Bool
_ Bool
_) = Int
digest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
digest'

instance Ord Expression where
  compare :: Expression -> Expression -> Ordering
compare (ExFormation [Binding]
bds) (ExFormation [Binding]
bds') = [Binding] -> [Binding] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Binding]
bds [Binding]
bds'
  compare (ExApplication Expression
expr Argument
arg) (ExApplication Expression
expr' Argument
arg') = Expression -> Expression -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Expression
expr Expression
expr' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Argument -> Argument -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Argument
arg Argument
arg'
  compare (ExDispatch Expression
expr Attribute
attr) (ExDispatch Expression
expr' Attribute
attr') = Expression -> Expression -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Expression
expr Expression
expr' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Attribute -> Attribute -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Attribute
attr Attribute
attr'
  compare (ExMeta Text
meta) (ExMeta Text
meta') = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
meta Text
meta'
  compare (ExAny Slot
slot) (ExAny Slot
slot') = Slot -> Slot -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Slot
slot Slot
slot'
  compare (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) (ExPhiMeet Maybe String
prefix' Int
idx' Expression
expr') = Maybe String -> Maybe String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe String
prefix Maybe String
prefix' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
idx Int
idx' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Expression -> Expression -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Expression
expr Expression
expr'
  compare (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) (ExPhiAgain Maybe String
prefix' Int
idx' Expression
expr') = Maybe String -> Maybe String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe String
prefix Maybe String
prefix' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
idx Int
idx' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Expression -> Expression -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Expression
expr Expression
expr'
  compare (ExBytes Bytes
bts) (ExBytes Bytes
bts') = Bytes -> Bytes -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bytes
bts Bytes
bts'
  compare Expression
left Expression
right = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Expression -> Int
rank Expression
left) (Expression -> Int
rank Expression
right)
    where
      rank :: Expression -> Int
      rank :: Expression -> Int
rank = \case
        ExFormation [Binding]
_ -> Int
0
        Expression
ExXi -> Int
1
        Expression
ExRoot -> Int
2
        Expression
ExTermination -> Int
3
        ExApplication Expression
_ Argument
_ -> Int
4
        ExDispatch Expression
_ Attribute
_ -> Int
5
        ExMeta Text
_ -> Int
6
        ExAny Slot
_ -> Int
7
        ExPhiMeet{} -> Int
8
        ExPhiAgain{} -> Int
9
        ExBytes Bytes
_ -> Int
10

instance Show Expression where
  showsPrec :: Int -> Expression -> ShowS
showsPrec Int
prec = \case
    ExFormation [Binding]
bds -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExFormation " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Binding] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [Binding]
bds)
    Expression
ExXi -> String -> ShowS
showString String
"ExXi"
    Expression
ExRoot -> String -> ShowS
showString String
"ExRoot"
    Expression
ExTermination -> String -> ShowS
showString String
"ExTermination"
    ExApplication Expression
expr Argument
arg -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExApplication " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expression -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Expression
expr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Argument -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Argument
arg)
    ExDispatch Expression
expr Attribute
attr -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExDispatch " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expression -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Expression
expr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Attribute -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Attribute
attr)
    ExMeta Text
meta -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExMeta " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Text
meta)
    ExAny Slot
slot -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExAny " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Slot -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Slot
slot)
    ExPhiMeet Maybe String
prefix Int
idx Expression
expr -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExPhiMeet " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe String
prefix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
idx ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expression -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Expression
expr)
    ExPhiAgain Maybe String
prefix Int
idx Expression
expr -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExPhiAgain " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe String
prefix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
idx ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expression -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Expression
expr)
    ExBytes Bytes
bts -> Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"ExBytes " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bytes -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Bytes
bts)

data Argument
  = ArTau Attribute Expression
  | ArAlpha Alpha Expression
  deriving (Argument -> Argument -> Bool
(Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool) -> Eq Argument
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Argument -> Argument -> Bool
== :: Argument -> Argument -> Bool
$c/= :: Argument -> Argument -> Bool
/= :: Argument -> Argument -> Bool
Eq, Eq Argument
Eq Argument =>
(Argument -> Argument -> Ordering)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Argument)
-> (Argument -> Argument -> Argument)
-> Ord Argument
Argument -> Argument -> Bool
Argument -> Argument -> Ordering
Argument -> Argument -> Argument
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Argument -> Argument -> Ordering
compare :: Argument -> Argument -> Ordering
$c< :: Argument -> Argument -> Bool
< :: Argument -> Argument -> Bool
$c<= :: Argument -> Argument -> Bool
<= :: Argument -> Argument -> Bool
$c> :: Argument -> Argument -> Bool
> :: Argument -> Argument -> Bool
$c>= :: Argument -> Argument -> Bool
>= :: Argument -> Argument -> Bool
$cmax :: Argument -> Argument -> Argument
max :: Argument -> Argument -> Argument
$cmin :: Argument -> Argument -> Argument
min :: Argument -> Argument -> Argument
Ord, Int -> Argument -> ShowS
[Argument] -> ShowS
Argument -> String
(Int -> Argument -> ShowS)
-> (Argument -> String) -> ([Argument] -> ShowS) -> Show Argument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Argument -> ShowS
showsPrec :: Int -> Argument -> ShowS
$cshow :: Argument -> String
show :: Argument -> String
$cshowList :: [Argument] -> ShowS
showList :: [Argument] -> ShowS
Show, (forall x. Argument -> Rep Argument x)
-> (forall x. Rep Argument x -> Argument) -> Generic Argument
forall x. Rep Argument x -> Argument
forall x. Argument -> Rep Argument x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Argument -> Rep Argument x
from :: forall x. Argument -> Rep Argument x
$cto :: forall x. Rep Argument x -> Argument
to :: forall x. Rep Argument x -> Argument
Generic)

data Alpha
  = Alpha Int
  | AlMeta Text
  | AlAny Slot
  deriving (Alpha -> Alpha -> Bool
(Alpha -> Alpha -> Bool) -> (Alpha -> Alpha -> Bool) -> Eq Alpha
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Alpha -> Alpha -> Bool
== :: Alpha -> Alpha -> Bool
$c/= :: Alpha -> Alpha -> Bool
/= :: Alpha -> Alpha -> Bool
Eq, Eq Alpha
Eq Alpha =>
(Alpha -> Alpha -> Ordering)
-> (Alpha -> Alpha -> Bool)
-> (Alpha -> Alpha -> Bool)
-> (Alpha -> Alpha -> Bool)
-> (Alpha -> Alpha -> Bool)
-> (Alpha -> Alpha -> Alpha)
-> (Alpha -> Alpha -> Alpha)
-> Ord Alpha
Alpha -> Alpha -> Bool
Alpha -> Alpha -> Ordering
Alpha -> Alpha -> Alpha
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Alpha -> Alpha -> Ordering
compare :: Alpha -> Alpha -> Ordering
$c< :: Alpha -> Alpha -> Bool
< :: Alpha -> Alpha -> Bool
$c<= :: Alpha -> Alpha -> Bool
<= :: Alpha -> Alpha -> Bool
$c> :: Alpha -> Alpha -> Bool
> :: Alpha -> Alpha -> Bool
$c>= :: Alpha -> Alpha -> Bool
>= :: Alpha -> Alpha -> Bool
$cmax :: Alpha -> Alpha -> Alpha
max :: Alpha -> Alpha -> Alpha
$cmin :: Alpha -> Alpha -> Alpha
min :: Alpha -> Alpha -> Alpha
Ord, (forall x. Alpha -> Rep Alpha x)
-> (forall x. Rep Alpha x -> Alpha) -> Generic Alpha
forall x. Rep Alpha x -> Alpha
forall x. Alpha -> Rep Alpha x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Alpha -> Rep Alpha x
from :: forall x. Alpha -> Rep Alpha x
$cto :: forall x. Rep Alpha x -> Alpha
to :: forall x. Rep Alpha x -> Alpha
Generic)

data Binding
  = BiTau Attribute Expression
  | BiVoid Attribute
  | BiDelta Bytes
  | BiLambda Function
  | BiMeta Text
  | BiAny Slot
  deriving (Binding -> Binding -> Bool
(Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool) -> Eq Binding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
/= :: Binding -> Binding -> Bool
Eq, Eq Binding
Eq Binding =>
(Binding -> Binding -> Ordering)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Binding)
-> (Binding -> Binding -> Binding)
-> Ord Binding
Binding -> Binding -> Bool
Binding -> Binding -> Ordering
Binding -> Binding -> Binding
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Binding -> Binding -> Ordering
compare :: Binding -> Binding -> Ordering
$c< :: Binding -> Binding -> Bool
< :: Binding -> Binding -> Bool
$c<= :: Binding -> Binding -> Bool
<= :: Binding -> Binding -> Bool
$c> :: Binding -> Binding -> Bool
> :: Binding -> Binding -> Bool
$c>= :: Binding -> Binding -> Bool
>= :: Binding -> Binding -> Bool
$cmax :: Binding -> Binding -> Binding
max :: Binding -> Binding -> Binding
$cmin :: Binding -> Binding -> Binding
min :: Binding -> Binding -> Binding
Ord, Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> String
(Int -> Binding -> ShowS)
-> (Binding -> String) -> ([Binding] -> ShowS) -> Show Binding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Binding -> ShowS
showsPrec :: Int -> Binding -> ShowS
$cshow :: Binding -> String
show :: Binding -> String
$cshowList :: [Binding] -> ShowS
showList :: [Binding] -> ShowS
Show, (forall x. Binding -> Rep Binding x)
-> (forall x. Rep Binding x -> Binding) -> Generic Binding
forall x. Rep Binding x -> Binding
forall x. Binding -> Rep Binding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Binding -> Rep Binding x
from :: forall x. Binding -> Rep Binding x
$cto :: forall x. Rep Binding x -> Binding
to :: forall x. Rep Binding x -> Binding
Generic)

data Bytes
  = BtEmpty
  | BtOne String
  | BtMany [String]
  | BtMeta Text
  | BtAny Slot
  deriving (Bytes -> Bytes -> Bool
(Bytes -> Bytes -> Bool) -> (Bytes -> Bytes -> Bool) -> Eq Bytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bytes -> Bytes -> Bool
== :: Bytes -> Bytes -> Bool
$c/= :: Bytes -> Bytes -> Bool
/= :: Bytes -> Bytes -> Bool
Eq, Eq Bytes
Eq Bytes =>
(Bytes -> Bytes -> Ordering)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> Ord Bytes
Bytes -> Bytes -> Bool
Bytes -> Bytes -> Ordering
Bytes -> Bytes -> Bytes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Bytes -> Bytes -> Ordering
compare :: Bytes -> Bytes -> Ordering
$c< :: Bytes -> Bytes -> Bool
< :: Bytes -> Bytes -> Bool
$c<= :: Bytes -> Bytes -> Bool
<= :: Bytes -> Bytes -> Bool
$c> :: Bytes -> Bytes -> Bool
> :: Bytes -> Bytes -> Bool
$c>= :: Bytes -> Bytes -> Bool
>= :: Bytes -> Bytes -> Bool
$cmax :: Bytes -> Bytes -> Bytes
max :: Bytes -> Bytes -> Bytes
$cmin :: Bytes -> Bytes -> Bytes
min :: Bytes -> Bytes -> Bytes
Ord, Int -> Bytes -> ShowS
[Bytes] -> ShowS
Bytes -> String
(Int -> Bytes -> ShowS)
-> (Bytes -> String) -> ([Bytes] -> ShowS) -> Show Bytes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bytes -> ShowS
showsPrec :: Int -> Bytes -> ShowS
$cshow :: Bytes -> String
show :: Bytes -> String
$cshowList :: [Bytes] -> ShowS
showList :: [Bytes] -> ShowS
Show, (forall x. Bytes -> Rep Bytes x)
-> (forall x. Rep Bytes x -> Bytes) -> Generic Bytes
forall x. Rep Bytes x -> Bytes
forall x. Bytes -> Rep Bytes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Bytes -> Rep Bytes x
from :: forall x. Bytes -> Rep Bytes x
$cto :: forall x. Rep Bytes x -> Bytes
to :: forall x. Rep Bytes x -> Bytes
Generic)

data Attribute
  = AtLabel Text
  | AtPhi
  | AtRho
  | AtLambda
  | AtDelta
  | AtMeta Text
  | AtAny Slot
  deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, (forall x. Attribute -> Rep Attribute x)
-> (forall x. Rep Attribute x -> Attribute) -> Generic Attribute
forall x. Rep Attribute x -> Attribute
forall x. Attribute -> Rep Attribute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Attribute -> Rep Attribute x
from :: forall x. Attribute -> Rep Attribute x
$cto :: forall x. Rep Attribute x -> Attribute
to :: forall x. Rep Attribute x -> Attribute
Generic, Eq Attribute
Eq Attribute =>
(Attribute -> Attribute -> Ordering)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Attribute)
-> (Attribute -> Attribute -> Attribute)
-> Ord Attribute
Attribute -> Attribute -> Bool
Attribute -> Attribute -> Ordering
Attribute -> Attribute -> Attribute
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Attribute -> Attribute -> Ordering
compare :: Attribute -> Attribute -> Ordering
$c< :: Attribute -> Attribute -> Bool
< :: Attribute -> Attribute -> Bool
$c<= :: Attribute -> Attribute -> Bool
<= :: Attribute -> Attribute -> Bool
$c> :: Attribute -> Attribute -> Bool
> :: Attribute -> Attribute -> Bool
$c>= :: Attribute -> Attribute -> Bool
>= :: Attribute -> Attribute -> Bool
$cmax :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
min :: Attribute -> Attribute -> Attribute
Ord)

data Function
  = Function Text
  | FnMeta Text
  | FnAny Slot
  | FnSymbol Int
  | FnFresh Slot
  deriving (Function -> Function -> Bool
(Function -> Function -> Bool)
-> (Function -> Function -> Bool) -> Eq Function
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Function -> Function -> Bool
== :: Function -> Function -> Bool
$c/= :: Function -> Function -> Bool
/= :: Function -> Function -> Bool
Eq, (forall x. Function -> Rep Function x)
-> (forall x. Rep Function x -> Function) -> Generic Function
forall x. Rep Function x -> Function
forall x. Function -> Rep Function x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Function -> Rep Function x
from :: forall x. Function -> Rep Function x
$cto :: forall x. Rep Function x -> Function
to :: forall x. Rep Function x -> Function
Generic, Int -> Function -> ShowS
[Function] -> ShowS
Function -> String
(Int -> Function -> ShowS)
-> (Function -> String) -> ([Function] -> ShowS) -> Show Function
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Function -> ShowS
showsPrec :: Int -> Function -> ShowS
$cshow :: Function -> String
show :: Function -> String
$cshowList :: [Function] -> ShowS
showList :: [Function] -> ShowS
Show, Eq Function
Eq Function =>
(Function -> Function -> Ordering)
-> (Function -> Function -> Bool)
-> (Function -> Function -> Bool)
-> (Function -> Function -> Bool)
-> (Function -> Function -> Bool)
-> (Function -> Function -> Function)
-> (Function -> Function -> Function)
-> Ord Function
Function -> Function -> Bool
Function -> Function -> Ordering
Function -> Function -> Function
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Function -> Function -> Ordering
compare :: Function -> Function -> Ordering
$c< :: Function -> Function -> Bool
< :: Function -> Function -> Bool
$c<= :: Function -> Function -> Bool
<= :: Function -> Function -> Bool
$c> :: Function -> Function -> Bool
> :: Function -> Function -> Bool
$c>= :: Function -> Function -> Bool
>= :: Function -> Function -> Bool
$cmax :: Function -> Function -> Function
max :: Function -> Function -> Function
$cmin :: Function -> Function -> Function
min :: Function -> Function -> Function
Ord)

instance Show Attribute where
  show :: Attribute -> String
show (AtLabel Text
label) = Text -> String
T.unpack Text
label
  show Attribute
AtRho = String
"ρ"
  show Attribute
AtPhi = String
"φ"
  show Attribute
AtDelta = String
"Δ"
  show Attribute
AtLambda = String
"λ"
  show (AtMeta Text
meta) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
meta
  show (AtAny (Slot Text
kind Int
_)) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
kind

instance Show Alpha where
  show :: Alpha -> String
show (Alpha Int
idx) = Char
'α' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
idx
  show (AlMeta Text
meta) = Char
'α' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
meta
  show (AlAny (Slot Text
kind Int
_)) = Char
'α' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
kind

hashExpression :: Expression -> Int
hashExpression :: Expression -> Int
hashExpression Expression
term = case Expression -> Facts
known Expression
term of
  Facts Int
digest Int
_ Bool
_ Bool
_ -> Int
digest

hashShape :: Expression -> Int
hashShape :: Expression -> Int
hashShape = (Int -> Int) -> (Expression -> Int) -> Expression -> Int
layer (Int -> Int -> Int
forall a b. a -> b -> a
const Int
0) Expression -> Int
hashShape

hashSkeleton :: Expression -> Int
hashSkeleton :: Expression -> Int
hashSkeleton =
  Expression -> Int
hashShape (Expression -> Int)
-> (Expression -> Expression) -> Expression -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    ExFormation [Binding]
bds -> [Binding] -> Expression
ExFormation ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Binding
bare [Binding]
bds)
    ExApplication Expression
_ (ArTau Attribute
attr Expression
_) -> Expression -> Argument -> Expression
ExApplication Expression
ExXi (Attribute -> Expression -> Argument
ArTau Attribute
attr Expression
ExXi)
    ExApplication Expression
_ (ArAlpha Alpha
alpha Expression
_) -> Expression -> Argument -> Expression
ExApplication Expression
ExXi (Alpha -> Expression -> Argument
ArAlpha Alpha
alpha Expression
ExXi)
    ExDispatch Expression
_ Attribute
attr -> Expression -> Attribute -> Expression
ExDispatch Expression
ExXi Attribute
attr
    ExPhiMeet Maybe String
prefix Int
idx Expression
_ -> Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx Expression
ExXi
    ExPhiAgain Maybe String
prefix Int
idx Expression
_ -> Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx Expression
ExXi
    Expression
term -> Expression
term
  where
    bare :: Binding -> Binding
    bare :: Binding -> Binding
bare (BiTau Attribute
attr Expression
_) = Attribute -> Expression -> Binding
BiTau Attribute
attr Expression
ExXi
    bare Binding
binding = Binding
binding

layer :: (Int -> Int) -> (Expression -> Int) -> Expression -> Int
layer :: (Int -> Int) -> (Expression -> Int) -> Expression -> Int
layer Int -> Int
symbol Expression -> Int
child = Int -> Expression -> Int
goExpr Int
fnvOffset
  where
    fnvPrime, fnvOffset :: Int
    fnvPrime :: Int
fnvPrime = Int
1099511628211
    fnvOffset :: Int
fnvOffset = Int
14695981039
    step :: Int -> Int -> Int
    step :: Int -> Int -> Int
step Int
h Int
x = (Int
h Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
fnvPrime
    hashText :: Int -> Text -> Int
    hashText :: Int -> Text -> Int
hashText = (Int -> Char -> Int) -> Int -> Text -> Int
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\Int
h Char
c -> Int -> Int -> Int
step Int
h (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))
    hashString :: Int -> String -> Int
    hashString :: Int -> String -> Int
hashString = (Int -> Char -> Int) -> Int -> String -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
h Char
c -> Int -> Int -> Int
step Int
h (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))
    goSlot :: Int -> Slot -> Int
    goSlot :: Int -> Slot -> Int
goSlot Int
h (Slot Text
kind Int
idx) = Int -> Int -> Int
step (Int -> Text -> Int
hashText Int
h Text
kind) Int
idx
    hashMaybeString :: Int -> Maybe String -> Int
    hashMaybeString :: Int -> Maybe String -> Int
hashMaybeString Int
h Maybe String
Nothing = Int -> Int -> Int
step Int
h Int
0
    hashMaybeString Int
h (Just String
s) = Int -> String -> Int
hashString (Int -> Int -> Int
step Int
h Int
1) String
s
    goExpr :: Int -> Expression -> Int
    goExpr :: Int -> Expression -> Int
goExpr Int
h = \case
      ExFormation [Binding]
bds -> (Int -> Binding -> Int) -> Int -> [Binding] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Binding -> Int
goBinding (Int -> Int -> Int
step Int
h Int
1) [Binding]
bds
      Expression
ExXi -> Int -> Int -> Int
step Int
h Int
2
      Expression
ExRoot -> Int -> Int -> Int
step Int
h Int
3
      Expression
ExTermination -> Int -> Int -> Int
step Int
h Int
4
      ExApplication Expression
ex Argument
arg -> Int -> Argument -> Int
goArgument (Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
5) (Expression -> Int
child Expression
ex)) Argument
arg
      ExDispatch Expression
ex Attribute
at -> Int -> Attribute -> Int
goAttribute (Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
6) (Expression -> Int
child Expression
ex)) Attribute
at
      ExMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
7) Text
t
      ExAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
32) Slot
slot
      ExPhiMeet Maybe String
ms Int
i Expression
ex -> Int -> Int -> Int
step (Int -> Maybe String -> Int
hashMaybeString (Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
9) Int
i) Maybe String
ms) (Expression -> Int
child Expression
ex)
      ExPhiAgain Maybe String
ms Int
i Expression
ex -> Int -> Int -> Int
step (Int -> Maybe String -> Int
hashMaybeString (Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
10) Int
i) Maybe String
ms) (Expression -> Int
child Expression
ex)
      ExBytes Bytes
bts -> Int -> Bytes -> Int
goBytes (Int -> Int -> Int
step Int
h Int
8) Bytes
bts
    goBinding :: Int -> Binding -> Int
    goBinding :: Int -> Binding -> Int
goBinding Int
h = \case
      BiTau Attribute
at Expression
ex -> Int -> Int -> Int
step (Int -> Attribute -> Int
goAttribute (Int -> Int -> Int
step Int
h Int
11) Attribute
at) (Expression -> Int
child Expression
ex)
      BiDelta Bytes
bts -> Int -> Bytes -> Int
goBytes (Int -> Int -> Int
step Int
h Int
12) Bytes
bts
      BiVoid Attribute
at -> Int -> Attribute -> Int
goAttribute (Int -> Int -> Int
step Int
h Int
13) Attribute
at
      BiLambda Function
fn -> Int -> Function -> Int
goFunction (Int -> Int -> Int
step Int
h Int
14) Function
fn
      BiMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
15) Text
t
      BiAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
33) Slot
slot
    goBytes :: Int -> Bytes -> Int
    goBytes :: Int -> Bytes -> Int
goBytes Int
h = \case
      Bytes
BtEmpty -> Int -> Int -> Int
step Int
h Int
17
      BtOne String
s -> Int -> String -> Int
hashString (Int -> Int -> Int
step Int
h Int
18) String
s
      BtMany [String]
ss -> (Int -> String -> Int) -> Int -> [String] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> String -> Int
hashString (Int -> Int -> Int
step Int
h Int
19) [String]
ss
      BtMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
20) Text
t
      BtAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
34) Slot
slot
    goAttribute :: Int -> Attribute -> Int
    goAttribute :: Int -> Attribute -> Int
goAttribute Int
h = \case
      AtLabel Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
21) Text
t
      Attribute
AtPhi -> Int -> Int -> Int
step Int
h Int
23
      Attribute
AtRho -> Int -> Int -> Int
step Int
h Int
24
      Attribute
AtLambda -> Int -> Int -> Int
step Int
h Int
25
      Attribute
AtDelta -> Int -> Int -> Int
step Int
h Int
26
      AtMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
27) Text
t
      AtAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
35) Slot
slot
    goArgument :: Int -> Argument -> Int
    goArgument :: Int -> Argument -> Int
goArgument Int
h = \case
      ArTau Attribute
at Expression
ex -> Int -> Int -> Int
step (Int -> Attribute -> Int
goAttribute (Int -> Int -> Int
step Int
h Int
22) Attribute
at) (Expression -> Int
child Expression
ex)
      ArAlpha Alpha
al Expression
ex -> Int -> Int -> Int
step (Int -> Alpha -> Int
goAlpha (Int -> Int -> Int
step Int
h Int
30) Alpha
al) (Expression -> Int
child Expression
ex)
    goAlpha :: Int -> Alpha -> Int
    goAlpha :: Int -> Alpha -> Int
goAlpha Int
h = \case
      Alpha Int
idx -> Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
31) Int
idx
      AlMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
28) Text
t
      AlAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
36) Slot
slot
    goFunction :: Int -> Function -> Int
    goFunction :: Int -> Function -> Int
goFunction Int
h = \case
      Function Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
16) Text
t
      FnMeta Text
t -> Int -> Text -> Int
hashText (Int -> Int -> Int
step Int
h Int
29) Text
t
      FnAny Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
37) Slot
slot
      FnSymbol Int
idx -> Int -> Int -> Int
step (Int -> Int -> Int
step Int
h Int
38) (Int -> Int
symbol Int
idx)
      FnFresh Slot
slot -> Int -> Slot -> Int
goSlot (Int -> Int -> Int
step Int
h Int
39) Slot
slot

alike :: Expression -> Expression -> Bool
alike :: Expression -> Expression -> Bool
alike Expression
one Expression
two = Maybe (Map Int Int, Map Int Int) -> Bool
forall a. Maybe a -> Bool
isJust ((Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int
forall k a. Map k a
Map.empty, Map Int Int
forall k a. Map k a
Map.empty) Expression
one Expression
two)
  where
    goExpr :: (Map.Map Int Int, Map.Map Int Int) -> Expression -> Expression -> Maybe (Map.Map Int Int, Map.Map Int Int)
    goExpr :: (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing (ExFormation [Binding]
left) (ExFormation [Binding]
right) = ((Map Int Int, Map Int Int)
 -> Binding -> Binding -> Maybe (Map Int Int, Map Int Int))
-> (Map Int Int, Map Int Int)
-> [Binding]
-> [Binding]
-> Maybe (Map Int Int, Map Int Int)
forall pairing item.
(pairing -> item -> item -> Maybe pairing)
-> pairing -> [item] -> [item] -> Maybe pairing
goList (Map Int Int, Map Int Int)
-> Binding -> Binding -> Maybe (Map Int Int, Map Int Int)
goBinding (Map Int Int, Map Int Int)
pairing [Binding]
left [Binding]
right
    goExpr (Map Int Int, Map Int Int)
pairing (ExApplication Expression
left Argument
arg) (ExApplication Expression
right Argument
arg') = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right Maybe (Map Int Int, Map Int Int)
-> ((Map Int Int, Map Int Int) -> Maybe (Map Int Int, Map Int Int))
-> Maybe (Map Int Int, Map Int Int)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Map Int Int, Map Int Int)
next -> (Map Int Int, Map Int Int)
-> Argument -> Argument -> Maybe (Map Int Int, Map Int Int)
goArgument (Map Int Int, Map Int Int)
next Argument
arg Argument
arg'
    goExpr (Map Int Int, Map Int Int)
pairing (ExDispatch Expression
left Attribute
attr) (ExDispatch Expression
right Attribute
attr')
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goExpr (Map Int Int, Map Int Int)
pairing (ExPhiMeet Maybe String
prefix Int
idx Expression
left) (ExPhiMeet Maybe String
prefix' Int
idx' Expression
right)
      | Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goExpr (Map Int Int, Map Int Int)
pairing (ExPhiAgain Maybe String
prefix Int
idx Expression
left) (ExPhiAgain Maybe String
prefix' Int
idx' Expression
right)
      | Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
forall item pairing.
Eq item =>
pairing -> item -> item -> Maybe pairing
same (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goBinding :: (Map.Map Int Int, Map.Map Int Int) -> Binding -> Binding -> Maybe (Map.Map Int Int, Map.Map Int Int)
    goBinding :: (Map Int Int, Map Int Int)
-> Binding -> Binding -> Maybe (Map Int Int, Map Int Int)
goBinding (Map Int Int, Map Int Int)
pairing (BiTau Attribute
attr Expression
left) (BiTau Attribute
attr' Expression
right)
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goBinding (Map Int Int, Map Int Int)
pairing (BiLambda (FnSymbol Int
left)) (BiLambda (FnSymbol Int
right)) = (Map Int Int, Map Int Int)
-> Int -> Int -> Maybe (Map Int Int, Map Int Int)
paired (Map Int Int, Map Int Int)
pairing Int
left Int
right
    goBinding (Map Int Int, Map Int Int)
pairing Binding
left Binding
right = (Map Int Int, Map Int Int)
-> Binding -> Binding -> Maybe (Map Int Int, Map Int Int)
forall item pairing.
Eq item =>
pairing -> item -> item -> Maybe pairing
same (Map Int Int, Map Int Int)
pairing Binding
left Binding
right
    goArgument :: (Map.Map Int Int, Map.Map Int Int) -> Argument -> Argument -> Maybe (Map.Map Int Int, Map.Map Int Int)
    goArgument :: (Map Int Int, Map Int Int)
-> Argument -> Argument -> Maybe (Map Int Int, Map Int Int)
goArgument (Map Int Int, Map Int Int)
pairing (ArTau Attribute
attr Expression
left) (ArTau Attribute
attr' Expression
right)
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goArgument (Map Int Int, Map Int Int)
pairing (ArAlpha Alpha
alpha Expression
left) (ArAlpha Alpha
alpha' Expression
right)
      | Alpha
alpha Alpha -> Alpha -> Bool
forall a. Eq a => a -> a -> Bool
== Alpha
alpha' = (Map Int Int, Map Int Int)
-> Expression -> Expression -> Maybe (Map Int Int, Map Int Int)
goExpr (Map Int Int, Map Int Int)
pairing Expression
left Expression
right
    goArgument (Map Int Int, Map Int Int)
pairing Argument
left Argument
right = (Map Int Int, Map Int Int)
-> Argument -> Argument -> Maybe (Map Int Int, Map Int Int)
forall item pairing.
Eq item =>
pairing -> item -> item -> Maybe pairing
same (Map Int Int, Map Int Int)
pairing Argument
left Argument
right
    goList :: (pairing -> item -> item -> Maybe pairing) -> pairing -> [item] -> [item] -> Maybe pairing
    goList :: forall pairing item.
(pairing -> item -> item -> Maybe pairing)
-> pairing -> [item] -> [item] -> Maybe pairing
goList pairing -> item -> item -> Maybe pairing
_ pairing
pairing [] [] = pairing -> Maybe pairing
forall a. a -> Maybe a
Just pairing
pairing
    goList pairing -> item -> item -> Maybe pairing
walk pairing
pairing (item
left : [item]
lefts) (item
right : [item]
rights) = pairing -> item -> item -> Maybe pairing
walk pairing
pairing item
left item
right Maybe pairing -> (pairing -> Maybe pairing) -> Maybe pairing
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pairing
next -> (pairing -> item -> item -> Maybe pairing)
-> pairing -> [item] -> [item] -> Maybe pairing
forall pairing item.
(pairing -> item -> item -> Maybe pairing)
-> pairing -> [item] -> [item] -> Maybe pairing
goList pairing -> item -> item -> Maybe pairing
walk pairing
next [item]
lefts [item]
rights
    goList pairing -> item -> item -> Maybe pairing
_ pairing
_ [item]
_ [item]
_ = Maybe pairing
forall a. Maybe a
Nothing
    same :: (Eq item) => pairing -> item -> item -> Maybe pairing
    same :: forall item pairing.
Eq item =>
pairing -> item -> item -> Maybe pairing
same pairing
pairing item
left item
right
      | item
left item -> item -> Bool
forall a. Eq a => a -> a -> Bool
== item
right = pairing -> Maybe pairing
forall a. a -> Maybe a
Just pairing
pairing
      | Bool
otherwise = Maybe pairing
forall a. Maybe a
Nothing
    paired :: (Map.Map Int Int, Map.Map Int Int) -> Int -> Int -> Maybe (Map.Map Int Int, Map.Map Int Int)
    paired :: (Map Int Int, Map Int Int)
-> Int -> Int -> Maybe (Map Int Int, Map Int Int)
paired (Map Int Int
forward, Map Int Int
backward) Int
left Int
right = case (Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
left Map Int Int
forward, Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
right Map Int Int
backward) of
      (Maybe Int
Nothing, Maybe Int
Nothing) -> (Map Int Int, Map Int Int) -> Maybe (Map Int Int, Map Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
left Int
right Map Int Int
forward, Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
right Int
left Map Int Int
backward)
      (Just Int
right', Just Int
_) | Int
right' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
right -> (Map Int Int, Map Int Int) -> Maybe (Map Int Int, Map Int Int)
forall a. a -> Maybe a
Just (Map Int Int
forward, Map Int Int
backward)
      (Maybe Int, Maybe Int)
_ -> Maybe (Map Int Int, Map Int Int)
forall a. Maybe a
Nothing

type Searched = Map.Map (Int, Int) [(Expression, Expression, Bool)]

type Search = Searched -> (Bool, Searched)

within :: Expression -> Expression -> Bool
within :: Expression -> Expression -> Bool
within Expression
before Expression
after = (Bool, Searched) -> Bool
forall a b. (a, b) -> a
fst (Expression -> Expression -> Search
coupled Expression
before Expression
after Searched
forall k a. Map k a
Map.empty)
  where
    embedded :: Expression -> Expression -> Search
    embedded :: Expression -> Expression -> Search
embedded Expression
inner Expression
outer Searched
searched = case Expression -> Expression -> Searched -> Maybe Bool
recalled Expression
inner Expression
outer Searched
searched of
      Just Bool
found -> (Bool
found, Searched
searched)
      Maybe Bool
Nothing -> Expression -> Expression -> (Bool, Searched) -> (Bool, Searched)
remembered Expression
inner Expression
outer ([Search] -> Search
some [Bool -> Search
answered (Expression -> Expression -> Bool
general Expression
inner Expression
outer), Expression -> Expression -> Search
coupled Expression
inner Expression
outer, [Search] -> Search
some ((Expression -> Search) -> [Expression] -> [Search]
forall a b. (a -> b) -> [a] -> [b]
map (Expression -> Expression -> Search
embedded Expression
inner) (Expression -> [Expression]
children Expression
outer))] Searched
searched)
    recalled :: Expression -> Expression -> Searched -> Maybe Bool
    recalled :: Expression -> Expression -> Searched -> Maybe Bool
recalled Expression
inner Expression
outer Searched
searched = [Bool] -> Maybe Bool
forall a. [a] -> Maybe a
listToMaybe [Bool
found | (Expression
inner', Expression
outer', Bool
found) <- [(Expression, Expression, Bool)]
-> (Int, Int) -> Searched -> [(Expression, Expression, Bool)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Expression -> Expression -> (Int, Int)
digests Expression
inner Expression
outer) Searched
searched, Expression
inner' Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
inner, Expression
outer' Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
outer]
    remembered :: Expression -> Expression -> (Bool, Searched) -> (Bool, Searched)
    remembered :: Expression -> Expression -> (Bool, Searched) -> (Bool, Searched)
remembered Expression
inner Expression
outer (Bool
found, Searched
searched) = (Bool
found, ([(Expression, Expression, Bool)]
 -> [(Expression, Expression, Bool)]
 -> [(Expression, Expression, Bool)])
-> (Int, Int)
-> [(Expression, Expression, Bool)]
-> Searched
-> Searched
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(Expression, Expression, Bool)]
-> [(Expression, Expression, Bool)]
-> [(Expression, Expression, Bool)]
forall a. [a] -> [a] -> [a]
(++) (Expression -> Expression -> (Int, Int)
digests Expression
inner Expression
outer) [(Expression
inner, Expression
outer, Bool
found)] Searched
searched)
    digests :: Expression -> Expression -> (Int, Int)
    digests :: Expression -> Expression -> (Int, Int)
digests Expression
inner Expression
outer = (Expression -> Int
hashExpression Expression
inner, Expression -> Int
hashExpression Expression
outer)
    general :: Expression -> Expression -> Bool
    general :: Expression -> Expression -> Bool
general Expression
inner (ExFormation [BiLambda (FnSymbol Int
_)]) = Expression -> Bool
plain Expression
inner
    general Expression
_ Expression
_ = Bool
False
    plain :: Expression -> Bool
    plain :: Expression -> Bool
plain (ExFormation [Binding]
bds) = (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Binding -> Bool
plainBinding [Binding]
bds
    plain (ExApplication Expression
expr (ArTau Attribute
AtRho Expression
_)) = Expression -> Bool
plain Expression
expr
    plain (ExApplication Expression
expr (ArTau Attribute
_ Expression
arg)) = Expression -> Bool
plain Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
plain Expression
arg
    plain (ExApplication Expression
expr (ArAlpha Alpha
_ Expression
arg)) = Expression -> Bool
plain Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
plain Expression
arg
    plain (ExDispatch Expression
expr Attribute
_) = Expression -> Bool
plain Expression
expr
    plain (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> Bool
plain Expression
expr
    plain (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> Bool
plain Expression
expr
    plain Expression
_ = Bool
True
    plainBinding :: Binding -> Bool
    plainBinding :: Binding -> Bool
plainBinding (BiTau Attribute
AtRho Expression
_) = Bool
True
    plainBinding (BiTau Attribute
_ Expression
expr) = Expression -> Bool
plain Expression
expr
    plainBinding (BiLambda (FnSymbol Int
_)) = Bool
False
    plainBinding Binding
_ = Bool
True
    coupled :: Expression -> Expression -> Search
    coupled :: Expression -> Expression -> Search
coupled (ExFormation [Binding]
left) (ExFormation [Binding]
right) = [Search] -> Search
every (Bool -> Search
answered ([Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
left 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]
right) Search -> [Search] -> [Search]
forall a. a -> [a] -> [a]
: (Binding -> Binding -> Search)
-> [Binding] -> [Binding] -> [Search]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Binding -> Binding -> Search
goBinding [Binding]
left [Binding]
right)
    coupled (ExApplication Expression
left Argument
arg) (ExApplication Expression
right Argument
arg') = [Search] -> Search
every [Expression -> Expression -> Search
embedded Expression
left Expression
right, Argument -> Argument -> Search
goArgument Argument
arg Argument
arg']
    coupled (ExDispatch Expression
left Attribute
attr) (ExDispatch Expression
right Attribute
attr') = [Search] -> Search
every [Bool -> Search
answered (Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    coupled (ExPhiMeet Maybe String
prefix Int
idx Expression
left) (ExPhiMeet Maybe String
prefix' Int
idx' Expression
right) = [Search] -> Search
every [Bool -> Search
answered (Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    coupled (ExPhiAgain Maybe String
prefix Int
idx Expression
left) (ExPhiAgain Maybe String
prefix' Int
idx' Expression
right) = [Search] -> Search
every [Bool -> Search
answered (Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    coupled Expression
left Expression
right = Bool -> Search
answered (Expression
left Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
right)
    goBinding :: Binding -> Binding -> Search
    goBinding :: Binding -> Binding -> Search
goBinding (BiTau Attribute
attr Expression
left) (BiTau Attribute
attr' Expression
right) = [Search] -> Search
every [Bool -> Search
answered (Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    goBinding (BiLambda (FnSymbol Int
_)) (BiLambda (FnSymbol Int
_)) = Bool -> Search
answered Bool
True
    goBinding Binding
left Binding
right = Bool -> Search
answered (Binding
left Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
right)
    goArgument :: Argument -> Argument -> Search
    goArgument :: Argument -> Argument -> Search
goArgument (ArTau Attribute
attr Expression
left) (ArTau Attribute
attr' Expression
right) = [Search] -> Search
every [Bool -> Search
answered (Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    goArgument (ArAlpha Alpha
alpha Expression
left) (ArAlpha Alpha
alpha' Expression
right) = [Search] -> Search
every [Bool -> Search
answered (Alpha
alpha Alpha -> Alpha -> Bool
forall a. Eq a => a -> a -> Bool
== Alpha
alpha'), Expression -> Expression -> Search
embedded Expression
left Expression
right]
    goArgument Argument
_ Argument
_ = Bool -> Search
answered Bool
False
    answered :: Bool -> Search
    answered :: Bool -> Search
answered = (,)
    every :: [Search] -> Search
    every :: [Search] -> Search
every [] Searched
searched = (Bool
True, Searched
searched)
    every (Search
search : [Search]
rest) Searched
searched = case Search
search Searched
searched of
      (Bool
True, Searched
searched') -> [Search] -> Search
every [Search]
rest Searched
searched'
      (Bool, Searched)
failed -> (Bool, Searched)
failed
    some :: [Search] -> Search
    some :: [Search] -> Search
some [] Searched
searched = (Bool
False, Searched
searched)
    some (Search
search : [Search]
rest) Searched
searched = case Search
search Searched
searched of
      (Bool
False, Searched
searched') -> [Search] -> Search
some [Search]
rest Searched
searched'
      (Bool, Searched)
found -> (Bool, Searched)
found
    children :: Expression -> [Expression]
    children :: Expression -> [Expression]
children (ExFormation [Binding]
bds) = [Expression
expr | BiTau Attribute
attr Expression
expr <- [Binding]
bds, Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute
AtRho]
    children (ExApplication Expression
expr (ArTau Attribute
_ Expression
arg)) = [Expression
expr, Expression
arg]
    children (ExApplication Expression
expr (ArAlpha Alpha
_ Expression
arg)) = [Expression
expr, Expression
arg]
    children (ExDispatch Expression
expr Attribute
_) = [Expression
expr]
    children (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = [Expression
expr]
    children (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = [Expression
expr]
    children Expression
_ = []

symbols :: Expression -> [Int]
symbols :: Expression -> [Int]
symbols = Expression -> [Int]
goExpr
  where
    goExpr :: Expression -> [Int]
    goExpr :: Expression -> [Int]
goExpr (ExFormation [Binding]
bds) = (Binding -> [Int]) -> [Binding] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Binding -> [Int]
goBinding [Binding]
bds
    goExpr (ExApplication Expression
expr Argument
arg) = Expression -> [Int]
goExpr Expression
expr [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Argument -> [Int]
goArgument Argument
arg
    goExpr (ExDispatch Expression
expr Attribute
_) = Expression -> [Int]
goExpr Expression
expr
    goExpr (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> [Int]
goExpr Expression
expr
    goExpr (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> [Int]
goExpr Expression
expr
    goExpr Expression
_ = []
    goBinding :: Binding -> [Int]
    goBinding :: Binding -> [Int]
goBinding (BiTau Attribute
_ Expression
expr) = Expression -> [Int]
goExpr Expression
expr
    goBinding (BiLambda (FnSymbol Int
idx)) = [Int
idx]
    goBinding Binding
_ = []
    goArgument :: Argument -> [Int]
    goArgument :: Argument -> [Int]
goArgument (ArTau Attribute
_ Expression
expr) = Expression -> [Int]
goExpr Expression
expr
    goArgument (ArAlpha Alpha
_ Expression
expr) = Expression -> [Int]
goExpr Expression
expr

lifted :: Int -> Int -> Expression -> Expression
lifted :: Int -> Int -> Expression -> Expression
lifted Int
floor' Int
offset = Expression -> Expression
goExpr
  where
    goExpr :: Expression -> Expression
    goExpr :: Expression -> Expression
goExpr (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Binding
goBinding [Binding]
bds)
    goExpr (ExApplication Expression
expr Argument
arg) = Expression -> Argument -> Expression
ExApplication (Expression -> Expression
goExpr Expression
expr) (Argument -> Argument
goArgument Argument
arg)
    goExpr (ExDispatch Expression
expr Attribute
attr) = Expression -> Attribute -> Expression
ExDispatch (Expression -> Expression
goExpr Expression
expr) Attribute
attr
    goExpr (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Expression -> Expression
goExpr Expression
expr)
    goExpr (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Expression -> Expression
goExpr Expression
expr)
    goExpr Expression
expr = Expression
expr
    goBinding :: Binding -> Binding
    goBinding :: Binding -> Binding
goBinding (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Expression
goExpr Expression
expr)
    goBinding (BiLambda (FnSymbol Int
idx)) | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
floor' = Function -> Binding
BiLambda (Int -> Function
FnSymbol (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset))
    goBinding Binding
bd = Binding
bd
    goArgument :: Argument -> Argument
    goArgument :: Argument -> Argument
goArgument (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Expression
goExpr Expression
expr)
    goArgument (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Expression -> Expression
goExpr Expression
expr)

denoted :: Expression -> Maybe Int
denoted :: Expression -> Maybe Int
denoted = Expression -> Maybe Int
goExpr
  where
    goExpr :: Expression -> Maybe Int
    goExpr :: Expression -> Maybe Int
goExpr (ExFormation [Binding]
bds) = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe ((Binding -> [Int]) -> [Binding] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Binding -> [Int]
goBinding [Binding]
bds)
    goExpr (ExApplication Expression
_ (ArTau Attribute
AtPhi Expression
expr)) = Expression -> Maybe Int
goExpr Expression
expr
    goExpr (ExApplication Expression
expr Argument
_) = Expression -> Maybe Int
goExpr Expression
expr
    goExpr (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> Maybe Int
goExpr Expression
expr
    goExpr (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> Maybe Int
goExpr Expression
expr
    goExpr Expression
_ = Maybe Int
forall a. Maybe a
Nothing
    goBinding :: Binding -> [Int]
    goBinding :: Binding -> [Int]
goBinding (BiLambda (FnSymbol Int
idx)) = [Int
idx]
    goBinding (BiTau Attribute
AtPhi Expression
expr) = [Int] -> (Int -> [Int]) -> Maybe Int -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Int -> [Int]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Maybe Int
goExpr Expression
expr)
    goBinding Binding
_ = []

countNodes :: Expression -> Int
countNodes :: Expression -> Int
countNodes Expression
term = case Expression -> Facts
known Expression
term of
  Facts Int
_ Int
size Bool
_ Bool
_ -> Int
size

tally :: Expression -> Int
tally :: Expression -> Int
tally (ExFormation [Binding]
bds) = 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
nodesInBinding [Binding]
bds) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bds
  where
    nodesInBinding :: Binding -> Int
    nodesInBinding :: Binding -> Int
nodesInBinding (BiTau Attribute
_ Expression
expr) = Expression -> Int
countNodes Expression
expr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
    nodesInBinding (BiMeta Text
_) = Int
1
    nodesInBinding (BiAny Slot
_) = Int
1
    nodesInBinding Binding
_ = Int
3
tally (ExApplication Expression
expr (ArTau Attribute
_ Expression
expr')) = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expression -> Int
countNodes Expression
expr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expression -> Int
countNodes Expression
expr'
tally (ExApplication Expression
expr (ArAlpha Alpha
_ Expression
expr')) = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expression -> Int
countNodes Expression
expr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expression -> Int
countNodes Expression
expr'
tally (ExDispatch Expression
expr' Attribute
_) = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expression -> Int
countNodes Expression
expr'
tally (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> Int
countNodes Expression
expr
tally (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> Int
countNodes Expression
expr
tally Expression
_ = Int
1

inert :: Expression -> Bool
inert :: Expression -> Bool
inert Expression
term = case Expression -> Facts
known Expression
term of
  Facts Int
_ Int
_ Bool
still Bool
_ -> Bool
still

distinct :: Expression -> Bool
distinct :: Expression -> Bool
distinct Expression
term = case Expression -> Facts
known Expression
term of
  Facts Int
_ Int
_ Bool
_ Bool
unique -> Bool
unique

unrepeated :: Expression -> Bool
unrepeated :: Expression -> Bool
unrepeated (ExFormation [Binding]
bds) = Maybe Attribute -> Bool
forall a. Maybe a -> Bool
isNothing ([Binding] -> Maybe Attribute
repeated [Binding]
bds)
unrepeated Expression
_ = Bool
True

repeated :: [Binding] -> Maybe Attribute
repeated :: [Binding] -> Maybe Attribute
repeated = IntMap [Attribute] -> [Binding] -> Maybe Attribute
go IntMap [Attribute]
forall a. IntMap a
IntMap.empty
  where
    go :: IntMap.IntMap [Attribute] -> [Binding] -> Maybe Attribute
    go :: IntMap [Attribute] -> [Binding] -> Maybe Attribute
go IntMap [Attribute]
_ [] = Maybe Attribute
forall a. Maybe a
Nothing
    go IntMap [Attribute]
seen (Binding
bd : [Binding]
rest) = case Binding -> Maybe Attribute
attributeFromBinding Binding
bd of
      Just Attribute
attr
        | Attribute
attr Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute] -> Int -> IntMap [Attribute] -> [Attribute]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] (Attribute -> Int
key Attribute
attr) IntMap [Attribute]
seen -> Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
attr
        | Bool
otherwise -> IntMap [Attribute] -> [Binding] -> Maybe Attribute
go (([Attribute] -> [Attribute] -> [Attribute])
-> Int -> [Attribute] -> IntMap [Attribute] -> IntMap [Attribute]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
(++) (Attribute -> Int
key Attribute
attr) [Attribute
attr] IntMap [Attribute]
seen) [Binding]
rest
      Maybe Attribute
Nothing -> IntMap [Attribute] -> [Binding] -> Maybe Attribute
go IntMap [Attribute]
seen [Binding]
rest
    key :: Attribute -> Int
    key :: Attribute -> Int
key (AtLabel Text
label) = (Int -> Char -> Int) -> Int -> Text -> Int
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\Int
hash Char
char -> (Int
hash Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
char) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1099511628211) Int
14695981039 Text
label
    key (AtMeta Text
meta) = Text -> Int
T.length Text
meta
    key Attribute
_ = Int
0

attributeFromBinding :: Binding -> Maybe Attribute
attributeFromBinding :: Binding -> Maybe Attribute
attributeFromBinding (BiTau Attribute
attr Expression
_) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
attr
attributeFromBinding (BiVoid Attribute
attr) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
attr
attributeFromBinding (BiDelta Bytes
_) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
AtDelta
attributeFromBinding (BiLambda Function
_) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
AtLambda
attributeFromBinding (BiMeta Text
_) = Maybe Attribute
forall a. Maybe a
Nothing
attributeFromBinding (BiAny Slot
_) = Maybe Attribute
forall a. Maybe a
Nothing

calm :: Expression -> Bool
calm :: Expression -> Bool
calm = \case
  ExFormation [Binding]
bds -> Bool -> Bool -> [Binding] -> Bool
settled Bool
False Bool
False [Binding]
bds
  ExDispatch Expression
expr Attribute
attr -> Expression -> Bool
inert Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
headless Expression
expr Bool -> Bool -> Bool
&& Attribute -> Bool
plain Attribute
attr
  ExApplication Expression
expr (ArTau Attribute
attr Expression
arg) -> Expression -> Bool
inert Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
headless Expression
expr Bool -> Bool -> Bool
&& Attribute -> Bool
plain Attribute
attr Bool -> Bool -> Bool
&& Expression -> Bool
inert Expression
arg
  ExApplication Expression
expr (ArAlpha (Alpha Int
_) Expression
arg) -> Expression -> Bool
inert Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
headless Expression
expr Bool -> Bool -> Bool
&& Expression -> Bool
inert Expression
arg
  Expression
ExXi -> Bool
True
  Expression
ExRoot -> Bool
True
  Expression
ExTermination -> Bool
True
  Expression
_ -> Bool
False
  where
    settled :: Bool -> Bool -> [Binding] -> Bool
    settled :: Bool -> Bool -> [Binding] -> Bool
settled Bool
_ Bool
_ [] = Bool
True
    settled Bool
lambda Bool
delta (Binding
bd : [Binding]
rest) =
      Binding -> Bool
quiet Binding
bd Bool -> Bool -> Bool
&& case Binding
bd of
        BiLambda Function
_ -> Bool -> Bool
not Bool
delta Bool -> Bool -> Bool
&& Bool -> Bool -> [Binding] -> Bool
settled Bool
True Bool
delta [Binding]
rest
        BiDelta Bytes
_ -> Bool -> Bool
not Bool
lambda Bool -> Bool -> Bool
&& Bool -> Bool -> [Binding] -> Bool
settled Bool
lambda Bool
True [Binding]
rest
        Binding
_ -> Bool -> Bool -> [Binding] -> Bool
settled Bool
lambda Bool
delta [Binding]
rest
    quiet :: Binding -> Bool
    quiet :: Binding -> Bool
quiet (BiTau Attribute
attr Expression
expr) = Attribute -> Bool
plain Attribute
attr Bool -> Bool -> Bool
&& Expression -> Bool
inert Expression
expr
    quiet (BiVoid Attribute
attr) = Attribute -> Bool
plain Attribute
attr
    quiet (BiDelta (BtMeta Text
_)) = Bool
False
    quiet (BiDelta (BtAny Slot
_)) = Bool
False
    quiet (BiDelta Bytes
_) = Bool
True
    quiet (BiLambda (Function Text
_)) = Bool
True
    quiet (BiLambda (FnSymbol Int
_)) = Bool
True
    quiet Binding
_ = Bool
False
    headless :: Expression -> Bool
    headless :: Expression -> Bool
headless (ExFormation [Binding]
_) = Bool
False
    headless Expression
ExTermination = Bool
False
    headless Expression
_ = Bool
True
    plain :: Attribute -> Bool
    plain :: Attribute -> Bool
plain (AtMeta Text
_) = Bool
False
    plain (AtAny Slot
_) = Bool
False
    plain Attribute
_ = Bool
True

matchBaseObject :: Expression -> Maybe T.Text
matchBaseObject :: Expression -> Maybe Text
matchBaseObject (ExDispatch Expression
ExRoot (AtLabel Text
label)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
label
matchBaseObject Expression
_ = Maybe Text
forall a. Maybe a
Nothing

pattern BaseObject :: T.Text -> Expression
pattern $mBaseObject :: forall {r}. Expression -> (Text -> r) -> ((# #) -> r) -> r
$bBaseObject :: Text -> Expression
BaseObject label <- (matchBaseObject -> Just label)
  where
    BaseObject Text
label = Expression -> Attribute -> Expression
ExDispatch Expression
ExRoot (Text -> Attribute
AtLabel Text
label)

matchDataObject :: Expression -> Maybe (T.Text, Bytes)
matchDataObject :: Expression -> Maybe (Text, Bytes)
matchDataObject (ExApplication Expression
outer Argument
arg)
  | Just Expression
inner <- Argument -> Maybe Expression
asBytesArg Argument
arg = case (Expression -> Maybe Text
matchOuter Expression
outer, Expression -> Maybe Bytes
matchInner Expression
inner) of
      (Just Text
label, Just Bytes
bts) -> (Text, Bytes) -> Maybe (Text, Bytes)
forall a. a -> Maybe a
Just (Text
label, Bytes
bts)
      (Maybe Text, Maybe Bytes)
_ -> Maybe (Text, Bytes)
forall a. Maybe a
Nothing
  where
    asBytesArg :: Argument -> Maybe Expression
    asBytesArg :: Argument -> Maybe Expression
asBytesArg (ArTau Attribute
AtPhi Expression
inner) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
inner
    asBytesArg (ArTau (AtLabel Text
"as-bytes") Expression
inner) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
inner
    asBytesArg (ArAlpha (Alpha Int
0) Expression
inner) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
inner
    asBytesArg Argument
_ = Maybe Expression
forall a. Maybe a
Nothing
    dataArg :: Argument -> Maybe Expression
    dataArg :: Argument -> Maybe Expression
dataArg (ArTau Attribute
AtPhi Expression
formation) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
formation
    dataArg (ArTau (AtLabel Text
"data") Expression
formation) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
formation
    dataArg (ArAlpha (Alpha Int
0) Expression
formation) = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
formation
    dataArg Argument
_ = Maybe Expression
forall a. Maybe a
Nothing
    matchOuter :: Expression -> Maybe T.Text
    matchOuter :: Expression -> Maybe Text
matchOuter (BaseObject Text
label) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
label
    matchOuter (ExPhiAgain Maybe String
_ Int
_ (BaseObject Text
label)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
label
    matchOuter Expression
_ = Maybe Text
forall a. Maybe a
Nothing
    matchInner :: Expression -> Maybe Bytes
    matchInner :: Expression -> Maybe Bytes
matchInner (ExPhiAgain Maybe String
_ Int
_ Expression
inner') = Expression -> Maybe Bytes
matchInner Expression
inner'
    matchInner Expression
inner' = Expression -> Maybe Bytes
matchInner' Expression
inner'
    matchInner' :: Expression -> Maybe Bytes
    matchInner' :: Expression -> Maybe Bytes
matchInner' (ExApplication Expression
bytes Argument
arg')
      | Just Expression
formation <- Argument -> Maybe Expression
dataArg Argument
arg' = case (Expression -> Bool
matchesBytes Expression
bytes, Expression -> Maybe Bytes
matchFormation Expression
formation) of
          (Bool
True, Just Bytes
bts) -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bts
          (Bool, Maybe Bytes)
_ -> Maybe Bytes
forall a. Maybe a
Nothing
    matchInner' Expression
_ = Maybe Bytes
forall a. Maybe a
Nothing
    matchesBytes :: Expression -> Bool
    matchesBytes :: Expression -> Bool
matchesBytes (BaseObject Text
"bytes") = Bool
True
    matchesBytes (ExPhiAgain Maybe String
_ Int
_ (BaseObject Text
"bytes")) = Bool
True
    matchesBytes Expression
_ = Bool
False
    matchFormation :: Expression -> Maybe Bytes
    matchFormation :: Expression -> Maybe Bytes
matchFormation (ExFormation [BiDelta Bytes
bts]) = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bts
    matchFormation (ExPhiAgain Maybe String
_ Int
_ (ExFormation [BiDelta Bytes
bts])) = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bts
    matchFormation Expression
_ = Maybe Bytes
forall a. Maybe a
Nothing
matchDataObject Expression
_ = Maybe (Text, Bytes)
forall a. Maybe a
Nothing

pattern DataString :: Bytes -> Expression
pattern $mDataString :: forall {r}. Expression -> (Bytes -> r) -> ((# #) -> r) -> r
$bDataString :: Bytes -> Expression
DataString bts = DataObject "string" bts

pattern DataNumber :: Bytes -> Expression
pattern $mDataNumber :: forall {r}. Expression -> (Bytes -> r) -> ((# #) -> r) -> r
$bDataNumber :: Bytes -> Expression
DataNumber bts = DataObject "number" bts

pattern DataObject :: T.Text -> Bytes -> Expression
pattern $mDataObject :: forall {r}. Expression -> (Text -> Bytes -> r) -> ((# #) -> r) -> r
$bDataObject :: Text -> Bytes -> Expression
DataObject label bts <- (matchDataObject -> Just (label, bts))
  where
    DataObject Text
label Bytes
bts =
      Expression -> Argument -> Expression
ExApplication (Text -> Expression
BaseObject Text
label) (Attribute -> Expression -> Argument
ArTau Attribute
AtPhi (Bytes -> Expression
dataBytes Bytes
bts))

dataBytes :: Bytes -> Expression
dataBytes :: Bytes -> Expression
dataBytes Bytes
bts =
  Expression -> Argument -> Expression
ExApplication
    (Text -> Expression
BaseObject Text
"bytes")
    (Attribute -> Expression -> Argument
ArTau Attribute
AtPhi ([Binding] -> Expression
ExFormation [Bytes -> Binding
BiDelta Bytes
bts]))