Function.hs

-- | Module for functionality common between the various Function types (AtomFunction, DatabaseContextFunction).
{-# LANGUAGE TypeApplications #-}
module ProjectM36.Function where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.AtomFunctionError (AtomFunctionError(AtomFunctionMissingReturnTypeError))
import ProjectM36.ScriptSession
import qualified Data.HashSet as HS
import Data.List (intercalate)
import qualified Data.Text as T

-- for merkle hash                       

-- | Return the underlying function to run the Function.
function :: FunctionBody a -> a
function (FunctionScriptBody _ f) = f
function (FunctionBuiltInBody f) = f
function (FunctionObjectLoadedBody _ _ _ f) = f

-- | Return the text-based Haskell script, if applicable.
functionScript :: Function a acl -> Maybe FunctionBodyScript
functionScript func = case funcBody func of
  FunctionScriptBody script _ -> Just script
  _ -> Nothing

-- | Change atom function definition to reference proper object file source. Useful when moving the object file into the database directory.
processObjectLoadedFunctionBody :: ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> FunctionBody a -> FunctionBody a
processObjectLoadedFunctionBody modName fentry objPath body =
  FunctionObjectLoadedBody objPath modName fentry f
  where
    f = function body

processObjectLoadedFunctions :: Functor f => ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> f (Function a acl) -> f (Function a acl)
processObjectLoadedFunctions modName entryName path =
  fmap (\f -> f { funcBody = processObjectLoadedFunctionBody modName entryName path (funcBody f) } )

loadFunctions :: ModName -> FuncName -> Maybe FilePath -> FilePath -> IO (Either LoadSymbolError [Function a acl])
#ifdef PM36_HASKELL_SCRIPTING
loadFunctions modName funcName' mModDir objPath =
  case mModDir of
    Just modDir -> do
      eNewFs <- loadFunctionFromDirectory LoadAutoObjectFile modName funcName' modDir objPath
      case eNewFs of
        Left err -> pure (Left err)
        Right newFs ->
          pure (Right (processFuncs newFs))
    Nothing -> do
      loadFunction LoadAutoObjectFile modName funcName' objPath
 where
   --functions inside object files probably won't have the right function body metadata
   processFuncs = map processor
   processor newF = newF { funcBody = processObjectLoadedFunctionBody modName funcName' objPath (funcBody newF)}
#else
loadFunctions _ _ _ _ = pure (Left LoadSymbolError)
#endif

functionForName :: FunctionName -> HS.HashSet (Function a acl) -> Either RelationalError (Function a acl)
functionForName funcName' funcSet =
  case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of
    [] -> Left $ NoSuchFunctionError funcName'
    x : _ -> Right x

{-
  \[IntegerAtom val1, IntegerAtom val2] -> 
     Right $ IntegerAtom $ apply_discount val1 val2
-}
wrapAtomFunction :: [AtomType] -> FunctionName -> Either RelationalError String
wrapAtomFunction aType@(_:_) funcName' =
  pure $
  -- we have to make a string-based, dynamic wrapper since we need to get a consistent function type out of the code
  -- there's no value in having an AtomFunction with no return type, so there must be a list with at least one value
    "\\[" <>
    wrapAtomArguments aType <>
    "] -> Right $ " <> 
    convType (last aType) <>
    " $ " <>
    T.unpack funcName' <>
    " " <>
    unwords (map (\i -> "val" <> show i) [1 .. length aType - 1])
wrapAtomFunction [] _ = Left (AtomFunctionUserError AtomFunctionMissingReturnTypeError)

-- | convert an AtomType into its constituent String value for use in constructing the Haskell scripting utility wrapper.
convType :: AtomType -> String
convType typ =
  case typ of
    IntegerAtomType -> "IntegerAtom"
    IntAtomType -> "IntAtom"
    ScientificAtomType -> "ScientificAtom"
    DoubleAtomType -> "DoubleAtom"
    TextAtomType -> "TextAtom"
    DayAtomType -> "DayAtom"
    DateTimeAtomType -> "DateTimeAtom"
    ByteStringAtomType -> "ByteStringAtom"
    BoolAtomType -> "BoolAtom"
    UUIDAtomType -> "UUIDAtom"
    RelationAtomType _ -> "RelationAtom" 
    SubrelationFoldAtomType _ -> "SubrelationFoldAtom" -- probably won't work
    ConstructedAtomType _ _ -> "ConstructedAtom" -- needs more work to render full atom metadata
    RelationalExprAtomType -> "RelationalExprAtom"
    TypeVariableType _ -> "" -- nonsense
    

wrapAtomArguments :: [AtomType] -> String
wrapAtomArguments atomArgs =
  intercalate "," (zipWith (\i c -> convType c <> " val" <> show @Int i) [1 ..] (init atomArgs))

wrapDatabaseContextFunction :: [AtomType] -> FunctionName -> String
wrapDatabaseContextFunction aType funcName' =
  "\\dbcfuncutils [" <>
  wrapAtomArguments (aType <> [TypeVariableType "databaseContextFunctionMonad"]) <> -- last type is throwaway
  "] dbContext -> " <>
  "let env = DatabaseContextFunctionMonadEnv dbcfuncutils in\n" <>
  "runDatabaseContextFunctionMonad env dbContext $ do\n" <>
  "  " <> T.unpack funcName' <> " " <>
  unwords (map (\i -> "val" <> show i) [1 .. length aType])

findFunctionByName :: FunctionName -> HS.HashSet (Function a acl) -> Maybe (Function a acl)
findFunctionByName fname funcs =
  case HS.toList (HS.filter (\f -> funcName f == fname) funcs) of
    [match] -> Just match
    _ -> Nothing -- returns nothing on multiple matches, too!

addOrReplaceFunction :: Function a acl -> HS.HashSet (Function a acl) -> HS.HashSet (Function a acl)
addOrReplaceFunction addFunc funcs =
  case findFunctionByName (funcName addFunc) funcs of
    Nothing -> -- no match, so just insert
      HS.insert addFunc funcs
    Just funcToReplace ->
      HS.insert addFunc (HS.delete funcToReplace funcs)