{-# LANGUAGE OverloadedStrings #-}

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

module Functions (buildTerm, buildFunctions, contextualizing, execFunctions, nameOf) where

import AST
import Builder
import Bytes (btsConcat, btsSize, btsToNum, btsToUnescapedStr, numToBts, strToBts)
import Contextualize (contextualize)
import Control.Exception (throwIO)
import Control.Monad (when)
import qualified Data.ByteString.Char8 as B
import Data.Functor
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Deps
import Logger (logDebug)
import Matcher
import Parser (ParserException (CouldNotParseAttribute), parseAttributeThrows, parseNumberThrows)
import Printer (printAttribute, printExpression, printExtraArg)
import Random (randomString)
import Regexp
import Tau (freshTau)
import Text.Printf (printf)
import qualified Yaml as Y

execFunctions :: [String]
execFunctions :: [String]
execFunctions = [String
"evaluate", String
"morph"]

buildFunctions :: [String]
buildFunctions :: [String]
buildFunctions = [String
"contextualize", String
"random-tau", String
"dataize", String
"concat", String
"sed", String
"random-string", String
"size", String
"tau", String
"string", String
"number", String
"sum", String
"join", String
"named"]

buildTerm :: BuildTermFunc
buildTerm :: BuildTermFunc
buildTerm String
func [ExtraArgument]
args Subst
subst = do
  String -> IO ()
logDebug (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Building new term using '%s' function..." String
func)
  BuildTermFunc
buildTerm' String
func [ExtraArgument]
args Subst
subst

buildTerm' :: BuildTermFunc
buildTerm' :: BuildTermFunc
buildTerm' String
"contextualize" = BuildTermMethod
_contextualize
buildTerm' String
"random-tau" = BuildTermMethod
_randomTau
buildTerm' String
"dataize" = BuildTermMethod
_dataize
buildTerm' String
"concat" = BuildTermMethod
_concat
buildTerm' String
"sed" = BuildTermMethod
_sed
buildTerm' String
"random-string" = BuildTermMethod
_randomString
buildTerm' String
"size" = BuildTermMethod
_size
buildTerm' String
"tau" = BuildTermMethod
_tau
buildTerm' String
"string" = BuildTermMethod
_string
buildTerm' String
"number" = BuildTermMethod
_number
buildTerm' String
"sum" = BuildTermMethod
_sum
buildTerm' String
"join" = BuildTermMethod
_join
buildTerm' String
func = BuildTermFunc
_unsupported String
func

argToBytes :: Y.ExtraArgument -> Subst -> IO Bytes
argToBytes :: ExtraArgument -> Subst -> IO Bytes
argToBytes (Y.ArgBytes Bytes
bytes) Subst
subst = Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst
argToBytes (Y.ArgExpression Expression
expr) Subst
subst = do
  (TeBytes Bytes
bts) <- BuildTermMethod
_dataize [Expression -> ExtraArgument
Y.ArgExpression Expression
expr] Subst
subst
  Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes
bts
argToBytes ExtraArgument
arg Subst
_ = IOError -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Can't extract bytes from given argument: %s" (ExtraArgument -> String
printExtraArg ExtraArgument
arg)))

argToString :: Y.ExtraArgument -> Subst -> IO String
argToString :: ExtraArgument -> Subst -> IO String
argToString ExtraArgument
arg Subst
subst = ExtraArgument -> Subst -> IO Bytes
argToBytes ExtraArgument
arg Subst
subst IO Bytes -> (Bytes -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bytes -> String
btsToUnescapedStr

argToNumber :: Y.ExtraArgument -> Subst -> IO Double
argToNumber :: ExtraArgument -> Subst -> IO Double
argToNumber (Y.ArgBytes Bytes
bytes) Subst
subst = Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst IO Bytes -> (Bytes -> IO Double) -> IO Double
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bytes -> IO Double
number
argToNumber arg :: ExtraArgument
arg@(Y.ArgExpression Expression
expr) Subst
subst = do
  Expression
expr' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  case Expression
expr' of
    DataNumber Bytes
_ -> IO Double
dataized
    DataObject Text
"bytes" Bytes
_ -> IO Double
dataized
    Expression
_ -> IOError -> IO Double
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Only numbers and bytes are supported by 'sum' function")
  where
    dataized :: IO Double
dataized = do
      TeBytes Bytes
bts <- BuildTermMethod
_dataize [ExtraArgument
arg] Subst
subst
      Bytes -> IO Double
number Bytes
bts
argToNumber ExtraArgument
arg Subst
_ = IOError -> IO Double
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Can't extract a number from given argument: %s" (ExtraArgument -> String
printExtraArg ExtraArgument
arg)))

number :: Bytes -> IO Double
number :: Bytes -> IO Double
number Bytes
bts = case Bytes -> Int
btsSize Bytes
bts of
  Int
8 -> Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Double
btsToNum Bytes
bts)
  Int
_ -> IOError -> IO Double
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Expected 8 bytes for a number, got %d" (Bytes -> Int
btsSize Bytes
bts)))

_contextualize :: BuildTermMethod
_contextualize :: BuildTermMethod
_contextualize = (Expression -> Expression -> IO Expression) -> BuildTermMethod
contextualizing Expression -> Expression -> IO Expression
contextualize

contextualizing :: (Expression -> Expression -> IO Expression) -> BuildTermMethod
contextualizing :: (Expression -> Expression -> IO Expression) -> BuildTermMethod
contextualizing Expression -> Expression -> IO Expression
judgment [Y.ArgExpression Expression
expr, Y.ArgExpression Expression
context] Subst
subst = do
  Expression
expr' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  Expression
context' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
context Subst
subst
  Expression -> Term
TeExpression (Expression -> Term) -> IO Expression -> IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> Expression -> IO Expression
judgment Expression
expr' Expression
context'
contextualizing Expression -> Expression -> IO Expression
_ [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function contextualize() requires exactly 2 arguments as expression")

nameOf :: Maybe Expression -> BuildTermMethod
nameOf :: Maybe Expression -> BuildTermMethod
nameOf Maybe Expression
universe [Y.ArgExpression Expression
expr] Subst
subst = do
  Expression
form <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Maybe Expression -> Expression -> Expression
nameIn Maybe Expression
universe Expression
form))
nameOf Maybe Expression
_ [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function named() requires exactly 1 argument as expression")

_randomTau :: BuildTermMethod
_randomTau :: BuildTermMethod
_randomTau [] Subst
_ = Attribute -> Term
TeAttribute (Attribute -> Term) -> (Text -> Attribute) -> Text -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Attribute
AtLabel (Text -> Term) -> IO Text -> IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
freshTau
_randomTau [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function random-tau() requires exactly 0 arguments")

_dataize :: BuildTermMethod
_dataize :: BuildTermMethod
_dataize [Y.ArgBytes Bytes
bytes] Subst
subst = do
  Bytes
bts <- Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Term
TeBytes Bytes
bts)
_dataize [Y.ArgExpression Expression
expr] Subst
subst = do
  Expression
expr' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  case Expression
expr' of
    DataObject Text
_ Bytes
bytes -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Term
TeBytes Bytes
bytes)
    ExApplication (BaseObject Text
"bytes") (ArTau Attribute
AtPhi (ExFormation [Binding]
bds)) | Just Bytes
bytes <- [Binding] -> Maybe Bytes
delta [Binding]
bds -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Term
TeBytes Bytes
bytes)
    ExApplication (BaseObject Text
"bytes") (ArAlpha (Alpha Int
0) (ExFormation [Binding]
bds)) | Just Bytes
bytes <- [Binding] -> Maybe Bytes
delta [Binding]
bds -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Term
TeBytes Bytes
bytes)
    ExFormation [Binding]
bds | Just Bytes
bytes <- [Binding] -> Maybe Bytes
delta [Binding]
bds -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Term
TeBytes Bytes
bytes)
    Expression
_ -> IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Only data objects and bytes are supported by 'dataize' function now")
  where
    delta :: [Binding] -> Maybe Bytes
    delta :: [Binding] -> Maybe Bytes
delta [Binding]
bds = case (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute -> Binding
BiVoid Attribute
AtRho) [Binding]
bds of
      [BiDelta Bytes
bytes] -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bytes
      [Binding]
_ -> Maybe Bytes
forall a. Maybe a
Nothing
_dataize [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function dataize() requires exactly 1 argument as expression or bytes")

_concat :: BuildTermMethod
_concat :: BuildTermMethod
_concat [ExtraArgument]
args Subst
subst = do
  [Bytes]
args' <- (ExtraArgument -> IO Bytes) -> [ExtraArgument] -> IO [Bytes]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ExtraArgument -> Subst -> IO Bytes
`argToBytes` Subst
subst) [ExtraArgument]
args
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataString ((Bytes -> Bytes -> Bytes) -> Bytes -> [Bytes] -> Bytes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Bytes -> Bytes -> Bytes
btsConcat Bytes
BtEmpty [Bytes]
args')))

_sed :: BuildTermMethod
_sed :: BuildTermMethod
_sed [ExtraArgument]
args Subst
subst = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ExtraArgument] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExtraArgument]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) (IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function sed() requires at least two arguments"))
  ByteString
first : [ByteString]
rest <-
    (ExtraArgument -> IO ByteString)
-> [ExtraArgument] -> IO [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      ( \ExtraArgument
arg -> do
          String
bts <- ExtraArgument -> Subst -> IO String
argToString ExtraArgument
arg Subst
subst
          ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack String
bts))
      )
      [ExtraArgument]
args
  ByteString
res <- ByteString -> [ByteString] -> IO ByteString
sed ByteString
first [ByteString]
rest
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataString (String -> Bytes
strToBts (Text -> String
T.unpack (OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode ByteString
res)))))
  where
    sed :: B.ByteString -> [B.ByteString] -> IO B.ByteString
    sed :: ByteString -> [ByteString] -> IO ByteString
sed ByteString
tgt [] = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
tgt
    sed ByteString
tgt (ByteString
ptn : [ByteString]
ptns) = do
      (ByteString
pat, ByteString
rep, Bool
global) <- ByteString -> IO (ByteString, ByteString, Bool)
parse ByteString
ptn
      Regex
regex <- ByteString -> IO Regex
compile ByteString
pat
      ByteString
next <-
        if Bool
global
          then Regex -> ByteString -> ByteString -> IO ByteString
replaceAll Regex
regex ByteString
rep ByteString
tgt
          else Regex -> ByteString -> ByteString -> IO ByteString
replaceFirst Regex
regex ByteString
rep ByteString
tgt
      ByteString -> [ByteString] -> IO ByteString
sed ByteString
next [ByteString]
ptns
    parse :: B.ByteString -> IO (B.ByteString, B.ByteString, Bool)
    parse :: ByteString -> IO (ByteString, ByteString, Bool)
parse ByteString
input =
      case ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"s/" ByteString
input of
        Just ByteString
body ->
          let (ByteString
pat, ByteString
rest, Bool
separator) = ByteString -> ByteString -> Bool -> (ByteString, ByteString, Bool)
nextUntilSlash ByteString
body ByteString
B.empty Bool
False
           in if Bool
separator
                then
                  let (ByteString
rep, ByteString
flag, Bool
sealed) = ByteString -> ByteString -> Bool -> (ByteString, ByteString, Bool)
nextUntilSlash ByteString
rest ByteString
B.empty Bool
True
                   in if Bool
sealed Bool -> Bool -> Bool
&& ByteString
flag ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"", ByteString
"g"]
                        then (ByteString, ByteString, Bool) -> IO (ByteString, ByteString, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
pat, ByteString
rep, ByteString
flag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"g")
                        else IOError -> IO (ByteString, ByteString, Bool)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"sed pattern must be in format s/pat/rep/[g]")
                else IOError -> IO (ByteString, ByteString, Bool)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"sed pattern must be in format s/pat/rep/[g]")
        Maybe ByteString
_ -> IOError -> IO (ByteString, ByteString, Bool)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"sed pattern must start with s/")
    nextUntilSlash :: B.ByteString -> B.ByteString -> Bool -> (B.ByteString, B.ByteString, Bool)
    nextUntilSlash :: ByteString -> ByteString -> Bool -> (ByteString, ByteString, Bool)
nextUntilSlash ByteString
input ByteString
acc Bool
escape = case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
input of
      Maybe (Char, ByteString)
Nothing -> (ByteString
acc, ByteString
B.empty, Bool
False)
      Just (Char
h, ByteString
rest)
        | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' -> case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
rest of
            Just (Char
h', ByteString
rest') -> ByteString -> ByteString -> Bool -> (ByteString, ByteString, Bool)
nextUntilSlash ByteString
rest' ((if Bool
escape then ByteString
acc else ByteString -> Char -> ByteString
B.snoc ByteString
acc Char
'\\') ByteString -> ByteString -> ByteString
`B.append` Char -> ByteString
B.singleton Char
h') Bool
escape
            Maybe (Char, ByteString)
Nothing -> (if Bool
escape then ByteString
acc else ByteString -> Char -> ByteString
B.snoc ByteString
acc Char
'\\', ByteString
B.empty, Bool
False)
        | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' -> (ByteString
acc, ByteString
rest, Bool
True)
        | Bool
otherwise -> ByteString -> ByteString -> Bool -> (ByteString, ByteString, Bool)
nextUntilSlash ByteString
rest (ByteString -> Char -> ByteString
B.snoc ByteString
acc Char
h) Bool
escape

_randomString :: BuildTermMethod
_randomString :: BuildTermMethod
_randomString [ExtraArgument
arg] Subst
subst = do
  String
pat <- ExtraArgument -> Subst -> IO String
argToString ExtraArgument
arg Subst
subst
  String
str <- String -> IO String
randomString String
pat
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataString (String -> Bytes
strToBts String
str)))
_randomString [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function random-string() requires exactly 1 dataizable argument")

_size :: BuildTermMethod
_size :: BuildTermMethod
_size [Y.ArgBinding (BiMeta Text
meta)] Subst
subst = do
  [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows (Text -> Binding
BiMeta Text
meta) Subst
subst
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataNumber (Double -> Bytes
numToBts (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bds)))))
_size [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function size() requires exactly 1 meta binding")

_tau :: BuildTermMethod
_tau :: BuildTermMethod
_tau [Y.ArgExpression Expression
expr] Subst
subst = do
  TeBytes Bytes
bts <- BuildTermMethod
_dataize [Expression -> ExtraArgument
Y.ArgExpression Expression
expr] Subst
subst
  let str :: String
str = Bytes -> String
btsToUnescapedStr Bytes
bts
  Attribute
attr <- String -> IO Attribute
parseAttributeThrows String
str
  let notReal :: IO a
notReal = ParserException -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> ParserException
CouldNotParseAttribute (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"'%s' is a meta attribute, not a real one" String
str))
  case Attribute
attr of
    AtMeta Text
_ -> IO Term
forall {a}. IO a
notReal
    AtAny Slot
_ -> IO Term
forall {a}. IO a
notReal
    Attribute
_ -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Term
TeAttribute Attribute
attr)
_tau [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function tau() requires exactly 1 argument as expression")

_string :: BuildTermMethod
_string :: BuildTermMethod
_string [Y.ArgExpression Expression
expr] Subst
subst = do
  Expression
expr' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  Expression
str <- case Expression
expr' of
    DataNumber Bytes
bts
      | Bytes -> Int
btsSize Bytes
bts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8 ->
          IOError -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Expected 8 bytes for a number, got %d" (Bytes -> Int
btsSize Bytes
bts)))
      | Bool
otherwise -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Expression
DataString (String -> Bytes
strToBts (Double -> String
spelled (Bytes -> Double
btsToNum Bytes
bts))))
    DataString Bytes
bts -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Expression
DataString Bytes
bts)
    Expression
ex ->
      IOError -> IO Expression
forall e a. Exception e => e -> IO a
throwIO
        ( String -> IOError
userError
            ( String -> String -> String
forall r. PrintfType r => String -> r
printf
                String
"Couldn't convert given expression to 'Φ.string' object, only 'Φ.number' or 'Φ.string' are allowed\n%s"
                (Expression -> String
printExpression Expression
ex)
            )
        )
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression Expression
str)
  where
    spelled :: Double -> String
    spelled :: Double -> String
spelled Double
num
      | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
num Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
num Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
num = Double -> String
forall a. Show a => a -> String
show Double
num
      | Bool
otherwise = case Double -> (Integer, Double)
forall b. Integral b => Double -> (b, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
num :: (Integer, Double) of
          (Integer
whole, Double
0.0) | Integer
whole Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
minBound :: Int) Bool -> Bool -> Bool
&& Integer
whole Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) -> Integer -> String
forall a. Show a => a -> String
show Integer
whole
          (Integer, Double)
_ -> Double -> String
forall a. Show a => a -> String
show Double
num
_string [Y.ArgAttribute Attribute
attr] Subst
subst = do
  Attribute
attr' <- Attribute -> Subst -> IO Attribute
buildAttributeThrows Attribute
attr Subst
subst
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataString (String -> Bytes
strToBts (Attribute -> String
printAttribute Attribute
attr'))))
_string [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function string() requires exactly 1 argument as attribute or data expression (Φ.number or Φ.string)")

_number :: BuildTermMethod
_number :: BuildTermMethod
_number [Y.ArgExpression Expression
expr] Subst
subst = do
  Expression
expr' <- Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst
  case Expression
expr' of
    DataString Bytes
bts -> do
      Expression
num <- String -> IO Expression
parseNumberThrows (Bytes -> String
btsToUnescapedStr Bytes
bts)
      Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression Expression
num)
    Expression
_ -> IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function number() expects expression to be 'Φ.string', but got:\n%s" (Expression -> String
printExpression Expression
expr')))
_number [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function number() requires exactly 1 argument as 'Φ.string'")

_sum :: BuildTermMethod
_sum :: BuildTermMethod
_sum [] Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function sum() requires at least 1 argument")
_sum [ExtraArgument]
args Subst
subst = do
  [Double]
nums <- (ExtraArgument -> IO Double) -> [ExtraArgument] -> IO [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ExtraArgument -> Subst -> IO Double
`argToNumber` Subst
subst) [ExtraArgument]
args
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression (Bytes -> Expression
DataNumber (Double -> Bytes
numToBts ([Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
nums))))

_join :: BuildTermMethod
_join :: BuildTermMethod
_join [] Subst
_ = Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Term
TeBindings [])
_join [ExtraArgument]
args Subst
subst = do
  [[Binding]]
bds <- [ExtraArgument] -> IO [[Binding]]
buildBindingGroups [ExtraArgument]
args
  [Binding] -> Term
TeBindings ([Binding] -> Term) -> IO [Binding] -> IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Binding]] -> Set Attribute -> IO [Binding]
go [[Binding]]
bds Set Attribute
forall a. Set a
Set.empty
  where
    buildBindingGroups :: [Y.ExtraArgument] -> IO [[Binding]]
    buildBindingGroups :: [ExtraArgument] -> IO [[Binding]]
buildBindingGroups [] = [[Binding]] -> IO [[Binding]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    buildBindingGroups (Y.ArgBinding Binding
bd : [ExtraArgument]
args') = do
      [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst
      [[Binding]]
next <- [ExtraArgument] -> IO [[Binding]]
buildBindingGroups [ExtraArgument]
args'
      [[Binding]] -> IO [[Binding]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding]
bds [Binding] -> [[Binding]] -> [[Binding]]
forall a. a -> [a] -> [a]
: [[Binding]]
next)
    buildBindingGroups [ExtraArgument]
_ = IOError -> IO [[Binding]]
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function join() can work with bindings only")
    go :: [[Binding]] -> Set.Set Attribute -> IO [Binding]
    go :: [[Binding]] -> Set Attribute -> IO [Binding]
go [] Set Attribute
_ = [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go ([Binding]
group : [[Binding]]
groups) Set Attribute
attrs = do
      ([Binding]
renamed, Set Attribute
next) <- [Binding] -> Set Attribute -> IO ([Binding], Set Attribute)
renameGroup [Binding]
group Set Attribute
attrs
      [Binding]
rest <- [[Binding]] -> Set Attribute -> IO [Binding]
go [[Binding]]
groups Set Attribute
next
      [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding]
renamed [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
rest)
    renameGroup :: [Binding] -> Set.Set Attribute -> IO ([Binding], Set.Set Attribute)
    renameGroup :: [Binding] -> Set Attribute -> IO ([Binding], Set Attribute)
renameGroup [Binding]
bds Set Attribute
attrs = do
      let groupAttrs :: Set Attribute
groupAttrs = [Attribute] -> Set Attribute
forall a. Ord a => [a] -> Set a
Set.fromList [Attribute
attr | Binding
bd <- [Binding]
bds, Just Attribute
attr <- [Binding -> Maybe Attribute
attributeFromBinding Binding
bd]]
      ([Binding]
renamed, Set Attribute
used, Map Attribute Attribute
changes) <- [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings [Binding]
bds Set Attribute
attrs (Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Attribute
attrs Set Attribute
groupAttrs) Map Attribute Attribute
forall k a. Map k a
Map.empty
      ([Binding], Set Attribute) -> IO ([Binding], Set Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Map Attribute Attribute -> Binding -> Binding
renameValue Map Attribute Attribute
changes) [Binding]
renamed, Set Attribute
used)
    renameBindings ::
      [Binding] ->
      Set.Set Attribute ->
      Set.Set Attribute ->
      Map.Map Attribute Attribute ->
      IO ([Binding], Set.Set Attribute, Map.Map Attribute Attribute)
    renameBindings :: [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings [] Set Attribute
attrs Set Attribute
_ Map Attribute Attribute
changes = ([Binding], Set Attribute, Map Attribute Attribute)
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Set Attribute
attrs, Map Attribute Attribute
changes)
    renameBindings (Binding
bd : [Binding]
bds) Set Attribute
attrs Set Attribute
unavailable Map Attribute Attribute
changes =
      case Binding -> Maybe Attribute
attributeFromBinding Binding
bd of
        Just Attribute
attr
          | Attribute -> Set Attribute -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attribute
attr Set Attribute
attrs Bool -> Bool -> Bool
&& (Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtRho Bool -> Bool -> Bool
|| Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtDelta Bool -> Bool -> Bool
|| Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtLambda) ->
              [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings [Binding]
bds Set Attribute
attrs Set Attribute
unavailable Map Attribute Attribute
changes
          | Attribute -> Set Attribute -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attribute
attr Set Attribute
attrs -> do
              Attribute
new <- Set Attribute -> IO Attribute
freshAttr Set Attribute
unavailable
              let renamed :: Binding
renamed = case Binding
bd of
                    BiTau Attribute
_ Expression
ex -> Attribute -> Expression -> Binding
BiTau Attribute
new Expression
ex
                    BiVoid Attribute
_ -> Attribute -> Binding
BiVoid Attribute
new
                    Binding
other -> Binding
other
              ([Binding]
rest, Set Attribute
used, Map Attribute Attribute
next) <-
                [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings
                  [Binding]
bds
                  (Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => a -> Set a -> Set a
Set.insert Attribute
new Set Attribute
attrs)
                  (Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => a -> Set a -> Set a
Set.insert Attribute
new Set Attribute
unavailable)
                  (Attribute
-> Attribute -> Map Attribute Attribute -> Map Attribute Attribute
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Attribute
attr Attribute
new Map Attribute Attribute
changes)
              ([Binding], Set Attribute, Map Attribute Attribute)
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding
renamed Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
rest, Set Attribute
used, Map Attribute Attribute
next)
          | Bool
otherwise -> do
              ([Binding]
rest, Set Attribute
used, Map Attribute Attribute
next) <-
                [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings
                  [Binding]
bds
                  (Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => a -> Set a -> Set a
Set.insert Attribute
attr Set Attribute
attrs)
                  Set Attribute
unavailable
                  Map Attribute Attribute
changes
              ([Binding], Set Attribute, Map Attribute Attribute)
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
rest, Set Attribute
used, Map Attribute Attribute
next)
        Maybe Attribute
Nothing -> do
          ([Binding]
rest, Set Attribute
used, Map Attribute Attribute
next) <- [Binding]
-> Set Attribute
-> Set Attribute
-> Map Attribute Attribute
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
renameBindings [Binding]
bds Set Attribute
attrs Set Attribute
unavailable Map Attribute Attribute
changes
          ([Binding], Set Attribute, Map Attribute Attribute)
-> IO ([Binding], Set Attribute, Map Attribute Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
rest, Set Attribute
used, Map Attribute Attribute
next)
    renameValue :: Map.Map Attribute Attribute -> Binding -> Binding
    renameValue :: Map Attribute Attribute -> Binding -> Binding
renameValue Map Attribute Attribute
changes (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau Attribute
attr (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr)
    renameValue Map Attribute Attribute
_ Binding
binding = Binding
binding
    renameExpression :: Map.Map Attribute Attribute -> Expression -> Expression
    renameExpression :: Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expression = case Expression
expression of
      ExFormation [Binding]
_ -> Expression
expression
      ExApplication Expression
expr Argument
arg -> Expression -> Argument -> Expression
ExApplication (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr) (Map Attribute Attribute -> Argument -> Argument
renameArgument Map Attribute Attribute
changes Argument
arg)
      ExDispatch Expression
ExXi Attribute
attr -> Expression -> Attribute -> Expression
ExDispatch Expression
ExXi (Attribute -> Attribute -> Map Attribute Attribute -> Attribute
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Attribute
attr Attribute
attr Map Attribute Attribute
changes)
      ExDispatch Expression
expr Attribute
attr -> Expression -> Attribute -> Expression
ExDispatch (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr) Attribute
attr
      ExPhiMeet Maybe String
prefix Int
idx Expression
expr -> Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr)
      ExPhiAgain Maybe String
prefix Int
idx Expression
expr -> Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr)
      Expression
other -> Expression
other
    renameArgument :: Map.Map Attribute Attribute -> Argument -> Argument
    renameArgument :: Map Attribute Attribute -> Argument -> Argument
renameArgument Map Attribute Attribute
changes (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr)
    renameArgument Map Attribute Attribute
changes (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Map Attribute Attribute -> Expression -> Expression
renameExpression Map Attribute Attribute
changes Expression
expr)
    freshAttr :: Set.Set Attribute -> IO Attribute
    freshAttr :: Set Attribute -> IO Attribute
freshAttr Set Attribute
unavailable = do
      Term
term <- BuildTermMethod
_randomTau [] Subst
subst
      case Term
term of
        TeAttribute Attribute
attr'
          | Attribute -> Set Attribute -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attribute
attr' Set Attribute
unavailable -> Set Attribute -> IO Attribute
freshAttr Set Attribute
unavailable
          | Bool
otherwise -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr'
        Term
_ -> IOError -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"random-tau() did not return an attribute, internal invariant violated")

_unsupported :: BuildTermFunc
_unsupported :: BuildTermFunc
_unsupported String
func [ExtraArgument]
_ Subst
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s() is not supported or does not exist" String
func))