{-# LANGUAGE CPP #-}
module ProjectM36.AtomFunction where
import ProjectM36.Base
import ProjectM36.Serialise.Base ()
import ProjectM36.Error
import ProjectM36.Relation
import ProjectM36.AtomType
import ProjectM36.AtomFunctionError
import ProjectM36.Function
import qualified ProjectM36.Attribute as A
import qualified Data.HashSet as HS
import qualified Data.Text as T

foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
--the underscore in the attribute name means that any attributes are acceptable
foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
foldAtomFuncType AtomType
foldType AtomType
returnType =
  [AtomType -> AtomType
SubrelationFoldAtomType AtomType
foldType,
   AtomType
returnType]

atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName :: TypeConstructorName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName TypeConstructorName
funcName' AtomFunctions
funcSet =
  case forall a. HashSet a -> [a]
HS.toList  forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (\AtomFunction
f -> forall a. Function a -> TypeConstructorName
funcName AtomFunction
f forall a. Eq a => a -> a -> Bool
== TypeConstructorName
funcName') AtomFunctions
funcSet of
    [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TypeConstructorName -> RelationalError
NoSuchFunctionError TypeConstructorName
funcName'
    AtomFunction
x : [AtomFunction]
_ -> forall a b. b -> Either a b
Right AtomFunction
x

-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.
emptyAtomFunction :: FunctionName -> AtomFunction
emptyAtomFunction :: TypeConstructorName -> AtomFunction
emptyAtomFunction TypeConstructorName
name = Function { funcName :: TypeConstructorName
funcName = TypeConstructorName
name,
                                    funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"],
                                    funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody forall a b. (a -> b) -> a -> b
$
                                               \case
                                                 Atom
x:[Atom]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
x
                                                 [Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
                                  }
                                          
                                          
-- | AtomFunction constructor for compiled-in functions.
compiledAtomFunction :: FunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
compiledAtomFunction :: TypeConstructorName
-> [AtomType]
-> ([Atom] -> Either AtomFunctionError Atom)
-> AtomFunction
compiledAtomFunction TypeConstructorName
name [AtomType]
aType [Atom] -> Either AtomFunctionError Atom
body = Function { funcName :: TypeConstructorName
funcName = TypeConstructorName
name,
                                                  funcType :: [AtomType]
funcType = [AtomType]
aType,
                                                  funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody [Atom] -> Either AtomFunctionError Atom
body }

--the atom function really should offer some way to return an error
evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
evalAtomFunction AtomFunction
func = forall a. FunctionBody a -> a
function (forall a. Function a -> FunctionBody a
funcBody AtomFunction
func)

--expect "Int -> Either AtomFunctionError Int"
--return "Int -> Int" for funcType
extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
extractAtomFunctionType [TypeConstructor]
typeIn = do
  let atomArgs :: [TypeConstructor]
atomArgs = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeConstructor]
typeIn forall a. Num a => a -> a -> a
- Int
1) [TypeConstructor]
typeIn
      --expected atom ret value - used to make funcType
      lastArg :: [TypeConstructor]
lastArg = forall a. Int -> [a] -> [a]
take Int
1 (forall a. [a] -> [a]
reverse [TypeConstructor]
typeIn)
  case [TypeConstructor]
lastArg of
    [ADTypeConstructor TypeConstructorName
"Either" 
     [ADTypeConstructor TypeConstructorName
"AtomFunctionError" [],
      TypeConstructor
atomRetArg]] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeConstructor]
atomArgs forall a. [a] -> [a] -> [a]
++ [TypeConstructor
atomRetArg])
    [TypeConstructor]
otherType -> 
      forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError (String -> String -> ScriptCompilationError
TypeCheckCompilationError String
"function returning \"Either AtomFunctionError a\"" (forall a. Show a => a -> String
show [TypeConstructor]
otherType)))
    
isScriptedAtomFunction :: AtomFunction -> Bool    
isScriptedAtomFunction :: AtomFunction -> Bool
isScriptedAtomFunction AtomFunction
func = case forall a. Function a -> FunctionBody a
funcBody AtomFunction
func of
  FunctionScriptBody{} -> Bool
True
  FunctionBody ([Atom] -> Either AtomFunctionError Atom)
_ -> Bool
False
  
-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.
createScriptedAtomFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr
createScriptedAtomFunction :: TypeConstructorName
-> [TypeConstructor]
-> TypeConstructor
-> TypeConstructorName
-> DatabaseContextIOExpr
createScriptedAtomFunction TypeConstructorName
funcName' [TypeConstructor]
argsType TypeConstructor
retType = forall a.
TypeConstructorName
-> [TypeConstructor]
-> TypeConstructorName
-> DatabaseContextIOExprBase a
AddAtomFunction TypeConstructorName
funcName' (
  [TypeConstructor]
argsType forall a. [a] -> [a] -> [a]
++ [forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
"Either" [
                forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
"AtomFunctionError" [],                     
                TypeConstructor
retType]])

{-
loadAtomFunctions :: ModName -> FuncName -> Maybe FilePath -> FilePath -> IO (Either LoadSymbolError [AtomFunction])
#ifdef PM36_HASKELL_SCRIPTING
Loadatomfunctions 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
loadAtomFunctions _ _ _ _ = pure (Left LoadSymbolError)
#endif
-}

atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
atomFunctionsAsRelation AtomFunctions
funcs = Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tups
  where tups :: [[Atom]]
tups = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Function a -> [Atom]
atomFuncToTuple (forall a. HashSet a -> [a]
HS.toList AtomFunctions
funcs)
        attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [TypeConstructorName -> AtomType -> Attribute
Attribute TypeConstructorName
"name" AtomType
TextAtomType,
                                     TypeConstructorName -> AtomType -> Attribute
Attribute TypeConstructorName
"arguments" AtomType
TextAtomType]
        atomFuncToTuple :: Function a -> [Atom]
atomFuncToTuple Function a
aFunc = [TypeConstructorName -> Atom
TextAtom (forall a. Function a -> TypeConstructorName
funcName Function a
aFunc),
                                 TypeConstructorName -> Atom
TextAtom (forall a. Function a -> TypeConstructorName
atomFuncTypeToText Function a
aFunc)]
        atomFuncTypeToText :: Function a -> TypeConstructorName
atomFuncTypeToText Function a
aFunc = TypeConstructorName -> [TypeConstructorName] -> TypeConstructorName
T.intercalate TypeConstructorName
" -> " (forall a b. (a -> b) -> [a] -> [b]
map AtomType -> TypeConstructorName
prettyAtomType (forall a. Function a -> [AtomType]
funcType Function a
aFunc))

--for calculating the merkle hash
  
-- | Used to mark functions which are loaded externally from the server.      
externalAtomFunction :: AtomFunctionBodyType -> AtomFunctionBody
externalAtomFunction :: ([Atom] -> Either AtomFunctionError Atom)
-> FunctionBody ([Atom] -> Either AtomFunctionError Atom)
externalAtomFunction = forall a. a -> FunctionBody a
FunctionBuiltInBody