{-# LANGUAGE OverloadedStrings #-}

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

module Functions (buildTerm) where

import Ast
import Builder
import Control.Exception (throwIO)
import Control.Monad (replicateM, when)
import qualified Data.ByteString.Char8 as B
import Data.Char (intToDigit)
import Data.Functor
import Data.Set (Set)
import qualified Data.Set
import qualified Data.Set as Set
import GHC.IO (unsafePerformIO)
import Matcher
import Misc
import Numeric (showHex)
import Parser (parseAttributeThrows, parseNumberThrows)
import Pretty
import Random (randomString)
import Regexp
import System.Random (randomRIO)
import Term
import Text.Printf (printf)
import qualified Yaml as Y

buildTerm :: BuildTermFunc
buildTerm :: BuildTermFunc
buildTerm String
"contextualize" = BuildTermMethod
_contextualize
buildTerm String
"scope" = BuildTermMethod
_scope
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 -> Program -> IO Bytes
argToBytes :: ExtraArgument -> Subst -> Program -> IO Bytes
argToBytes (Y.ArgBytes Bytes
bytes) Subst
subst Program
_ = Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst
argToBytes (Y.ArgExpression Expression
expr) Subst
subst Program
prog = do
  (TeBytes Bytes
bts) <- BuildTermMethod
_dataize [Expression -> ExtraArgument
Y.ArgExpression Expression
expr] Subst
subst Program
prog
  Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes
bts
argToBytes ExtraArgument
arg Subst
_ Program
_ = 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
prettyExtraArg ExtraArgument
arg)))

argToString :: Y.ExtraArgument -> Subst -> Program -> IO String
argToString :: ExtraArgument -> Subst -> Program -> IO String
argToString ExtraArgument
arg Subst
subst Program
prog = ExtraArgument -> Subst -> Program -> IO Bytes
argToBytes ExtraArgument
arg Subst
subst Program
prog 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 -> Program -> IO Double
argToNumber :: ExtraArgument -> Subst -> Program -> IO Double
argToNumber ExtraArgument
arg Subst
subst Program
prog = ExtraArgument -> Subst -> Program -> IO Bytes
argToBytes ExtraArgument
arg Subst
subst Program
prog IO Bytes -> (Bytes -> Double) -> IO Double
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Integer -> Double)
-> (Double -> Double) -> Either Integer Double -> Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> Double
toDouble Double -> Double
forall a. a -> a
id (Either Integer Double -> Double)
-> (Bytes -> Either Integer Double) -> Bytes -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either Integer Double
btsToNum

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

_scope :: BuildTermMethod
_scope :: BuildTermMethod
_scope [Y.ArgExpression Expression
expr] Subst
subst Program
_ = do
  (Expression
_, Expression
scope) <- Expression -> Subst -> IO (Expression, 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 Expression
scope)
_scope [ExtraArgument]
_ Subst
_ Program
_ = IOError -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function scope() requires exactly 1 argument as expression")

_randomTau :: BuildTermMethod
_randomTau :: BuildTermMethod
_randomTau [ExtraArgument]
args Subst
subst Program
_ = do
  [String]
attrs <- [ExtraArgument] -> IO [String]
argsToAttrs [ExtraArgument]
args
  String
tau <- [String] -> IO String
randomTau [String]
attrs
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Term
TeAttribute (String -> Attribute
AtLabel String
tau))
  where
    argsToAttrs :: [Y.ExtraArgument] -> IO [String]
    argsToAttrs :: [ExtraArgument] -> IO [String]
argsToAttrs [] = [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    argsToAttrs (ExtraArgument
arg : [ExtraArgument]
rest) = case ExtraArgument
arg of
      Y.ArgExpression Expression
_ -> [ExtraArgument] -> IO [String]
argsToAttrs [ExtraArgument]
rest
      Y.ArgAttribute Attribute
attr -> do
        Attribute
attr' <- Attribute -> Subst -> IO Attribute
buildAttributeThrows Attribute
attr Subst
subst
        [String]
rest' <- [ExtraArgument] -> IO [String]
argsToAttrs [ExtraArgument]
rest
        [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> String
prettyAttribute Attribute
attr' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest')
      Y.ArgBinding Binding
bd -> do
        [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst
        [String]
rest' <- [ExtraArgument] -> IO [String]
argsToAttrs [ExtraArgument]
rest
        [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Attribute -> String) -> [Attribute] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> String
forall a. Show a => a -> String
show ([Binding] -> [Attribute]
attributesFromBindings [Binding]
bds) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rest')
      Y.ArgBytes Bytes
_ -> IOError -> IO [String]
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Bytes can't be argument of random-tau() function")
    randomTau :: [String] -> IO String
    randomTau :: [String] -> IO String
randomTau [String]
attrs = do
      String
tau <- String -> IO String
randomString String
"a🌵%d"
      if String
tau String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
attrs then [String] -> IO String
randomTau [String]
attrs else String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
tau

_dataize :: BuildTermMethod
_dataize :: BuildTermMethod
_dataize [Y.ArgBytes Bytes
bytes] Subst
subst Program
_ = 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 Program
_ = do
  (Expression
expr', Expression
_) <- Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
expr Subst
subst
  case Expression
expr' of
    DataObject String
_ Bytes
bytes -> 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")
_dataize [ExtraArgument]
_ Subst
_ Program
_ = 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 Program
prog = do
  [String]
args' <- (ExtraArgument -> IO String) -> [ExtraArgument] -> IO [String]
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 -> ExtraArgument -> Subst -> Program -> IO String
argToString ExtraArgument
arg Subst
subst Program
prog) [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 (String -> Bytes
strToBts ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
args'))))

_sed :: BuildTermMethod
_sed :: BuildTermMethod
_sed [ExtraArgument]
args Subst
subst Program
prog = 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]
args' <-
    (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 -> Program -> IO String
argToString ExtraArgument
arg Subst
subst Program
prog
          ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ByteString
B.pack String
bts)
      )
      [ExtraArgument]
args
  ByteString
res <- ByteString -> [ByteString] -> IO ByteString
sed ([ByteString] -> ByteString
forall a. HasCallStack => [a] -> a
head [ByteString]
args') ([ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
tail [ByteString]
args')
  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 (ByteString -> String
B.unpack 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) = ByteString -> ByteString -> Bool -> (ByteString, ByteString)
nextUntilSlash ByteString
body ByteString
B.empty Bool
False
              (ByteString
rep, ByteString
flag) = ByteString -> ByteString -> Bool -> (ByteString, ByteString)
nextUntilSlash ByteString
rest ByteString
B.empty Bool
True
           in case [ByteString
pat, ByteString
rep, ByteString
flag] of
                [ByteString
pat, ByteString
rep, ByteString
"g"] -> (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, Bool
True)
                [ByteString
pat, ByteString
rep, ByteString
""] -> (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, Bool
False)
                [ByteString]
_ -> 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/")
    -- Cut part from given string until regular slash.
    nextUntilSlash :: B.ByteString -> B.ByteString -> Bool -> (B.ByteString, B.ByteString)
    nextUntilSlash :: ByteString -> ByteString -> Bool -> (ByteString, ByteString)
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)
      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)
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)
        | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' -> (ByteString
acc, ByteString
rest)
        | Bool
otherwise -> ByteString -> ByteString -> Bool -> (ByteString, ByteString)
nextUntilSlash ByteString
rest (ByteString -> Char -> ByteString
B.snoc ByteString
acc Char
h) Bool
escape

_randomString :: BuildTermMethod
_randomString :: BuildTermMethod
_randomString [ExtraArgument
arg] Subst
subst Program
prog = do
  String
pat <- ExtraArgument -> Subst -> Program -> IO String
argToString ExtraArgument
arg Subst
subst Program
prog
  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
_ Program
_ = 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 String
meta)] Subst
subst Program
_ = do
  [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows (String -> Binding
BiMeta String
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
_ Program
_ = 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 Program
prog = do
  TeBytes Bytes
bts <- BuildTermMethod
_dataize [Expression -> ExtraArgument
Y.ArgExpression Expression
expr] Subst
subst Program
prog
  Attribute
attr <- String -> IO Attribute
parseAttributeThrows (Bytes -> String
btsToUnescapedStr Bytes
bts)
  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
_ Program
_ = 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 Program
_ = do
  (Expression
expr', Expression
_) <- Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
expr Subst
subst
  Expression
str <- case Expression
expr' of
    DataNumber Bytes
bts -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Expression
DataString (String -> Bytes
strToBts ((Integer -> String)
-> (Double -> String) -> Either Integer Double -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> String
forall a. Show a => a -> String
show Double -> String
forall a. Show a => a -> String
show (Bytes -> Either Integer 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
exp ->
      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
prettyExpression' Expression
exp)
            )
        )
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Term
TeExpression Expression
str)
_string [Y.ArgAttribute Attribute
attr] Subst
subst Program
_ = 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
prettyAttribute Attribute
attr'))))
_string [ExtraArgument]
_ Subst
_ Program
_ = 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 Program
_ = do
  (Expression
expr', Expression
_) <- Expression -> Subst -> IO (Expression, 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
prettyExpression' Expression
expr')))
_number [ExtraArgument]
_ Subst
_ Program
_ = 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 [ExtraArgument]
args Subst
subst Program
prog = 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
arg -> ExtraArgument -> Subst -> Program -> IO Double
argToNumber ExtraArgument
arg Subst
subst Program
prog) [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
_ Program
_ = 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 Program
_ = do
  [Binding]
bds <- [ExtraArgument] -> IO [Binding]
buildBindings [ExtraArgument]
args
  Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Term
TeBindings ([Binding] -> Set Attribute -> [Binding]
join' [Binding]
bds Set Attribute
forall a. Set a
Set.empty))
  where
    buildBindings :: [Y.ExtraArgument] -> IO [Binding]
    buildBindings :: [ExtraArgument] -> IO [Binding]
buildBindings [] = [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    buildBindings (Y.ArgBinding Binding
bd : [ExtraArgument]
args') = do
      [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst
      [Binding]
next <- [ExtraArgument] -> IO [Binding]
buildBindings [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)
    buildBindings [ExtraArgument]
_ = IOError -> IO [Binding]
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Function 'join' can work with bindings only")
    join' :: [Binding] -> Set.Set Attribute -> [Binding]
    join' :: [Binding] -> Set Attribute -> [Binding]
join' [] Set Attribute
_ = []
    join' (Binding
bd : [Binding]
bds) Set Attribute
attrs =
      let [Attribute
attr] = [Binding] -> [Attribute]
attributesFromBindings [Binding
bd]
       in if Attribute -> Set Attribute -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attribute
attr Set Attribute
attrs
            then
              if 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
                then [Binding] -> Set Attribute -> [Binding]
join' [Binding]
bds Set Attribute
attrs
                else
                  let new :: Binding
new = case Binding
bd of
                        BiTau Attribute
attr Expression
expr -> Attribute -> Expression -> Binding
BiTau (Attribute -> Set Attribute -> Attribute
updated Attribute
attr Set Attribute
attrs) Expression
expr
                        BiVoid Attribute
attr -> Attribute -> Binding
BiVoid (Attribute -> Set Attribute -> Attribute
updated Attribute
attr Set Attribute
attrs)
                   in Binding
new Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> Set Attribute -> [Binding]
join' [Binding]
bds Set Attribute
attrs
            else Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> Set Attribute -> [Binding]
join' [Binding]
bds (Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => a -> Set a -> Set a
Set.insert Attribute
attr Set Attribute
attrs)
    updated :: Attribute -> Set.Set Attribute -> Attribute
    updated :: Attribute -> Set Attribute -> Attribute
updated Attribute
attr Set Attribute
attrs =
      let (TeAttribute Attribute
attr') = IO Term -> Term
forall a. IO a -> a
unsafePerformIO (BuildTermMethod
_randomTau ((Attribute -> ExtraArgument) -> [Attribute] -> [ExtraArgument]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> ExtraArgument
Y.ArgAttribute (Set Attribute -> [Attribute]
forall a. Set a -> [a]
Set.toList Set Attribute
attrs)) Subst
subst (Expression -> Program
Program Expression
ExGlobal))
       in Attribute
attr'

_unsupported :: BuildTermFunc
_unsupported :: BuildTermFunc
_unsupported String
func [ExtraArgument]
_ Subst
_ Program
_ = 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))