phino-0.0.152: src/Functions.hs
{-# 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 Misc
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 = ["evaluate", "morph"]
buildFunctions :: [String]
buildFunctions = ["contextualize", "random-tau", "dataize", "concat", "sed", "random-string", "size", "tau", "string", "number", "sum", "join", "named"]
buildTerm :: BuildTermFunc
buildTerm func args subst = do
logDebug (printf "Building new term using '%s' function..." func)
buildTerm' func args subst
buildTerm' :: BuildTermFunc
buildTerm' "contextualize" = _contextualize
buildTerm' "random-tau" = _randomTau
buildTerm' "dataize" = _dataize
buildTerm' "concat" = _concat
buildTerm' "sed" = _sed
buildTerm' "random-string" = _randomString
buildTerm' "size" = _size
buildTerm' "tau" = _tau
buildTerm' "string" = _string
buildTerm' "number" = _number
buildTerm' "sum" = _sum
buildTerm' "join" = _join
buildTerm' func = _unsupported func
argToBytes :: Y.ExtraArgument -> Subst -> IO Bytes
argToBytes (Y.ArgBytes bytes) subst = buildBytesThrows bytes subst
argToBytes (Y.ArgExpression expr) subst = do
(TeBytes bts) <- _dataize [Y.ArgExpression expr] subst
pure bts
argToBytes arg _ = throwIO (userError (printf "Can't extract bytes from given argument: %s" (printExtraArg arg)))
argToString :: Y.ExtraArgument -> Subst -> IO String
argToString arg subst = argToBytes arg subst <&> btsToUnescapedStr
argToNumber :: Y.ExtraArgument -> Subst -> IO Double
argToNumber arg subst = do
bts <- argToBytes arg subst
case btsSize bts of
8 -> pure (either toDouble id (btsToNum bts))
_ -> throwIO (userError (printf "Expected 8 bytes for a number, got %d" (btsSize bts)))
_contextualize :: BuildTermMethod
_contextualize = contextualizing contextualize
contextualizing :: (Expression -> Expression -> IO Expression) -> BuildTermMethod
contextualizing judgment [Y.ArgExpression expr, Y.ArgExpression context] subst = do
expr' <- buildExpressionThrows expr subst
context' <- buildExpressionThrows context subst
TeExpression <$> judgment expr' context'
contextualizing _ _ _ = throwIO (userError "Function contextualize() requires exactly 2 arguments as expression")
nameOf :: Maybe Expression -> BuildTermMethod
nameOf universe [Y.ArgExpression expr] subst = do
form <- buildExpressionThrows expr subst
pure (TeExpression (nameIn universe form))
nameOf _ _ _ = throwIO (userError "Function named() requires exactly 1 argument as expression")
_randomTau :: BuildTermMethod
_randomTau [] _ = TeAttribute . AtLabel <$> freshTau
_randomTau _ _ = throwIO (userError "Function random-tau() requires exactly 0 arguments")
_dataize :: BuildTermMethod
_dataize [Y.ArgBytes bytes] subst = do
bts <- buildBytesThrows bytes subst
pure (TeBytes bts)
_dataize [Y.ArgExpression expr] subst = do
expr' <- buildExpressionThrows expr subst
case expr' of
DataObject _ bytes -> pure (TeBytes bytes)
ExApplication (BaseObject "bytes") (ArTau AtPhi (ExFormation bds)) | Just bytes <- delta bds -> pure (TeBytes bytes)
ExApplication (BaseObject "bytes") (ArAlpha (Alpha 0) (ExFormation bds)) | Just bytes <- delta bds -> pure (TeBytes bytes)
ExFormation bds | Just bytes <- delta bds -> pure (TeBytes bytes)
_ -> throwIO (userError "Only data objects and bytes are supported by 'dataize' function now")
where
delta :: [Binding] -> Maybe Bytes
delta bds = case filter (/= BiVoid AtRho) bds of
[BiDelta bytes] -> Just bytes
_ -> Nothing
_dataize _ _ = throwIO (userError "Function dataize() requires exactly 1 argument as expression or bytes")
_concat :: BuildTermMethod
_concat args subst = do
args' <- traverse (`argToBytes` subst) args
pure (TeExpression (DataString (foldl btsConcat BtEmpty args')))
_sed :: BuildTermMethod
_sed args subst = do
when (length args < 2) (throwIO (userError "Function sed() requires at least two arguments"))
first : rest <-
traverse
( \arg -> do
bts <- argToString arg subst
pure (T.encodeUtf8 (T.pack bts))
)
args
res <- sed first rest
pure (TeExpression (DataString (strToBts (T.unpack (T.decodeUtf8With T.lenientDecode res)))))
where
sed :: B.ByteString -> [B.ByteString] -> IO B.ByteString
sed tgt [] = pure tgt
sed tgt (ptn : ptns) = do
(pat, rep, global) <- parse ptn
regex <- compile pat
next <-
if global
then replaceAll regex rep tgt
else replaceFirst regex rep tgt
sed next ptns
parse :: B.ByteString -> IO (B.ByteString, B.ByteString, Bool)
parse input =
case B.stripPrefix "s/" input of
Just body ->
let (pat, rest, separator) = nextUntilSlash body B.empty False
in if separator
then
let (rep, flag, _) = nextUntilSlash rest B.empty True
in case flag of
"g" -> pure (pat, rep, True)
"" -> pure (pat, rep, False)
_ -> throwIO (userError "sed pattern must be in format s/pat/rep/[g]")
else throwIO (userError "sed pattern must be in format s/pat/rep/[g]")
_ -> throwIO (userError "sed pattern must start with s/")
nextUntilSlash :: B.ByteString -> B.ByteString -> Bool -> (B.ByteString, B.ByteString, Bool)
nextUntilSlash input acc escape = case B.uncons input of
Nothing -> (acc, B.empty, False)
Just (h, rest)
| h == '\\' -> case B.uncons rest of
Just (h', rest') -> nextUntilSlash rest' ((if escape then acc else B.snoc acc '\\') `B.append` B.singleton h') escape
Nothing -> (if escape then acc else B.snoc acc '\\', B.empty, False)
| h == '/' -> (acc, rest, True)
| otherwise -> nextUntilSlash rest (B.snoc acc h) escape
_randomString :: BuildTermMethod
_randomString [arg] subst = do
pat <- argToString arg subst
str <- randomString pat
pure (TeExpression (DataString (strToBts str)))
_randomString _ _ = throwIO (userError "Function random-string() requires exactly 1 dataizable argument")
_size :: BuildTermMethod
_size [Y.ArgBinding (BiMeta meta)] subst = do
bds <- buildBindingThrows (BiMeta meta) subst
pure (TeExpression (DataNumber (numToBts (fromIntegral (length bds)))))
_size _ _ = throwIO (userError "Function size() requires exactly 1 meta binding")
_tau :: BuildTermMethod
_tau [Y.ArgExpression expr] subst = do
TeBytes bts <- _dataize [Y.ArgExpression expr] subst
let str = btsToUnescapedStr bts
attr <- parseAttributeThrows str
let notReal = throwIO (CouldNotParseAttribute (printf "'%s' is a meta attribute, not a real one" str))
case attr of
AtMeta _ -> notReal
AtAny _ -> notReal
_ -> pure (TeAttribute attr)
_tau _ _ = throwIO (userError "Function tau() requires exactly 1 argument as expression")
_string :: BuildTermMethod
_string [Y.ArgExpression expr] subst = do
expr' <- buildExpressionThrows expr subst
str <- case expr' of
DataNumber bts
| btsSize bts /= 8 ->
throwIO (userError (printf "Expected 8 bytes for a number, got %d" (btsSize bts)))
| otherwise -> pure (DataString (strToBts (either show show (btsToNum bts))))
DataString bts -> pure (DataString bts)
ex ->
throwIO
( userError
( printf
"Couldn't convert given expression to 'Φ.string' object, only 'Φ.number' or 'Φ.string' are allowed\n%s"
(printExpression ex)
)
)
pure (TeExpression str)
_string [Y.ArgAttribute attr] subst = do
attr' <- buildAttributeThrows attr subst
pure (TeExpression (DataString (strToBts (printAttribute attr'))))
_string _ _ = throwIO (userError "Function string() requires exactly 1 argument as attribute or data expression (Φ.number or Φ.string)")
_number :: BuildTermMethod
_number [Y.ArgExpression expr] subst = do
expr' <- buildExpressionThrows expr subst
case expr' of
DataString bts -> do
num <- parseNumberThrows (btsToUnescapedStr bts)
pure (TeExpression num)
_ -> throwIO (userError (printf "Function number() expects expression to be 'Φ.string', but got:\n%s" (printExpression expr')))
_number _ _ = throwIO (userError "Function number() requires exactly 1 argument as 'Φ.string'")
_sum :: BuildTermMethod
_sum [] _ = throwIO (userError "Function sum() requires at least 1 argument")
_sum args subst = do
nums <- traverse (`argToNumber` subst) args
pure (TeExpression (DataNumber (numToBts (sum nums))))
_join :: BuildTermMethod
_join [] _ = pure (TeBindings [])
_join args subst = do
bds <- buildBindingGroups args
TeBindings <$> go bds Set.empty
where
buildBindingGroups :: [Y.ExtraArgument] -> IO [[Binding]]
buildBindingGroups [] = pure []
buildBindingGroups (Y.ArgBinding bd : args') = do
bds <- buildBindingThrows bd subst
next <- buildBindingGroups args'
pure (bds : next)
buildBindingGroups _ = throwIO (userError "Function join() can work with bindings only")
go :: [[Binding]] -> Set.Set Attribute -> IO [Binding]
go [] _ = pure []
go (group : groups) attrs = do
(renamed, next) <- renameGroup group attrs
rest <- go groups next
pure (renamed ++ rest)
renameGroup :: [Binding] -> Set.Set Attribute -> IO ([Binding], Set.Set Attribute)
renameGroup bds attrs = do
let groupAttrs = Set.fromList [attr | bd <- bds, Just attr <- [attributeFromBinding bd]]
(renamed, used, changes) <- renameBindings bds attrs (Set.union attrs groupAttrs) Map.empty
pure (map (renameValue changes) renamed, used)
renameBindings ::
[Binding] ->
Set.Set Attribute ->
Set.Set Attribute ->
Map.Map Attribute Attribute ->
IO ([Binding], Set.Set Attribute, Map.Map Attribute Attribute)
renameBindings [] attrs _ changes = pure ([], attrs, changes)
renameBindings (bd : bds) attrs unavailable changes =
case attributeFromBinding bd of
Just attr
| Set.member attr attrs && (attr == AtRho || attr == AtDelta || attr == AtLambda) ->
renameBindings bds attrs unavailable changes
| Set.member attr attrs -> do
new <- freshAttr unavailable
let renamed = case bd of
BiTau _ ex -> BiTau new ex
BiVoid _ -> BiVoid new
other -> other
(rest, used, next) <-
renameBindings
bds
(Set.insert new attrs)
(Set.insert new unavailable)
(Map.insert attr new changes)
pure (renamed : rest, used, next)
| otherwise -> do
(rest, used, next) <-
renameBindings
bds
(Set.insert attr attrs)
unavailable
changes
pure (bd : rest, used, next)
Nothing -> do
(rest, used, next) <- renameBindings bds attrs unavailable changes
pure (bd : rest, used, next)
renameValue :: Map.Map Attribute Attribute -> Binding -> Binding
renameValue changes (BiTau attr expr) = BiTau attr (renameExpression changes expr)
renameValue _ binding = binding
renameExpression :: Map.Map Attribute Attribute -> Expression -> Expression
renameExpression changes expression = case expression of
ExFormation _ -> expression
ExApplication expr arg -> ExApplication (renameExpression changes expr) (renameArgument changes arg)
ExDispatch ExXi attr -> ExDispatch ExXi (Map.findWithDefault attr attr changes)
ExDispatch expr attr -> ExDispatch (renameExpression changes expr) attr
ExPhiMeet prefix idx expr -> ExPhiMeet prefix idx (renameExpression changes expr)
ExPhiAgain prefix idx expr -> ExPhiAgain prefix idx (renameExpression changes expr)
other -> other
renameArgument :: Map.Map Attribute Attribute -> Argument -> Argument
renameArgument changes (ArTau attr expr) = ArTau attr (renameExpression changes expr)
renameArgument changes (ArAlpha alpha expr) = ArAlpha alpha (renameExpression changes expr)
freshAttr :: Set.Set Attribute -> IO Attribute
freshAttr unavailable = do
term <- _randomTau [] subst
case term of
TeAttribute attr'
| Set.member attr' unavailable -> freshAttr unavailable
| otherwise -> pure attr'
_ -> throwIO (userError "random-tau() did not return an attribute, internal invariant violated")
_unsupported :: BuildTermFunc
_unsupported func _ _ = throwIO (userError (printf "Function %s() is not supported or does not exist" func))