{-# 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
import qualified Data.ByteString.Lazy as BL
import Codec.Winery

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 = [Attributes -> AtomType
RelationAtomType ([Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"_" AtomType
foldType]), AtomType
returnType]

atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName :: AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
funcSet = if AtomFunctions -> Bool
forall a. HashSet a -> Bool
HS.null AtomFunctions
foundFunc then
                                         RelationalError -> Either RelationalError AtomFunction
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError AtomFunction)
-> RelationalError -> Either RelationalError AtomFunction
forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationalError
NoSuchFunctionError AttributeName
funcName'
                                        else
                                         AtomFunction -> Either RelationalError AtomFunction
forall a b. b -> Either a b
Right (AtomFunction -> Either RelationalError AtomFunction)
-> AtomFunction -> Either RelationalError AtomFunction
forall a b. (a -> b) -> a -> b
$ [AtomFunction] -> AtomFunction
forall a. [a] -> a
head ([AtomFunction] -> AtomFunction) -> [AtomFunction] -> AtomFunction
forall a b. (a -> b) -> a -> b
$ AtomFunctions -> [AtomFunction]
forall a. HashSet a -> [a]
HS.toList AtomFunctions
foundFunc
  where
    foundFunc :: AtomFunctions
foundFunc = (AtomFunction -> Bool) -> AtomFunctions -> AtomFunctions
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (\AtomFunction
f -> AtomFunction -> AttributeName
forall a. Function a -> AttributeName
funcName AtomFunction
f AttributeName -> AttributeName -> Bool
forall a. Eq a => a -> a -> Bool
== AttributeName
funcName') AtomFunctions
funcSet

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

--the atom function really should offer some way to return an error
evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
evalAtomFunction :: AtomFunction -> AtomFunctionBodyType
evalAtomFunction AtomFunction
func = FunctionBody AtomFunctionBodyType -> AtomFunctionBodyType
forall a. FunctionBody a -> a
function (AtomFunction -> FunctionBody AtomFunctionBodyType
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 = Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take ([TypeConstructor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeConstructor]
typeIn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [TypeConstructor]
typeIn
      --expected atom ret value - used to make funcType
      lastArg :: [TypeConstructor]
lastArg = Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take Int
1 ([TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a]
reverse [TypeConstructor]
typeIn)
  case [TypeConstructor]
lastArg of
    [ADTypeConstructor AttributeName
"Either" 
     [ADTypeConstructor AttributeName
"AtomFunctionError" [],
      TypeConstructor
atomRetArg]] ->
      [TypeConstructor] -> Either RelationalError [TypeConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeConstructor]
atomArgs [TypeConstructor] -> [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a] -> [a]
++ [TypeConstructor
atomRetArg])
    [TypeConstructor]
otherType -> 
      RelationalError -> Either RelationalError [TypeConstructor]
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError (String -> String -> ScriptCompilationError
TypeCheckCompilationError String
"function returning \"Either AtomFunctionError a\"" ([TypeConstructor] -> String
forall a. Show a => a -> String
show [TypeConstructor]
otherType)))
    
isScriptedAtomFunction :: AtomFunction -> Bool    
isScriptedAtomFunction :: AtomFunction -> Bool
isScriptedAtomFunction AtomFunction
func = case AtomFunction -> FunctionBody AtomFunctionBodyType
forall a. Function a -> FunctionBody a
funcBody AtomFunction
func of
  FunctionScriptBody{} -> Bool
True
  FunctionBody AtomFunctionBodyType
_ -> 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 :: AttributeName
-> [TypeConstructor]
-> TypeConstructor
-> AttributeName
-> DatabaseContextIOExpr
createScriptedAtomFunction AttributeName
funcName' [TypeConstructor]
argsType TypeConstructor
retType = AttributeName
-> [TypeConstructor] -> AttributeName -> DatabaseContextIOExpr
forall a.
AttributeName
-> [TypeConstructor]
-> AttributeName
-> DatabaseContextIOExprBase a
AddAtomFunction AttributeName
funcName' (
  [TypeConstructor]
argsType [TypeConstructor] -> [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a] -> [a]
++ [AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"Either" [
                AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"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 = (AtomFunction -> [Atom]) -> [AtomFunction] -> [[Atom]]
forall a b. (a -> b) -> [a] -> [b]
map AtomFunction -> [Atom]
forall a. Function a -> [Atom]
atomFuncToTuple (AtomFunctions -> [AtomFunction]
forall a. HashSet a -> [a]
HS.toList AtomFunctions
funcs)
        attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"name" AtomType
TextAtomType,
                                     AttributeName -> AtomType -> Attribute
Attribute AttributeName
"arguments" AtomType
TextAtomType]
        atomFuncToTuple :: Function a -> [Atom]
atomFuncToTuple Function a
aFunc = [AttributeName -> Atom
TextAtom (Function a -> AttributeName
forall a. Function a -> AttributeName
funcName Function a
aFunc),
                                 AttributeName -> Atom
TextAtom (Function a -> AttributeName
forall a. Function a -> AttributeName
atomFuncTypeToText Function a
aFunc)]
        atomFuncTypeToText :: Function a -> AttributeName
atomFuncTypeToText Function a
aFunc = AttributeName -> [AttributeName] -> AttributeName
T.intercalate AttributeName
" -> " ((AtomType -> AttributeName) -> [AtomType] -> [AttributeName]
forall a b. (a -> b) -> [a] -> [b]
map AtomType -> AttributeName
prettyAtomType (Function a -> [AtomType]
forall a. Function a -> [AtomType]
funcType Function a
aFunc))

--for calculating the merkle hash
hashBytes :: AtomFunction -> BL.ByteString
hashBytes :: AtomFunction -> ByteString
hashBytes AtomFunction
func = [ByteString] -> ByteString
BL.fromChunks [AttributeName -> ByteString
forall a. Serialise a => a -> ByteString
serialise (AtomFunction -> AttributeName
forall a. Function a -> AttributeName
funcName AtomFunction
func),
                                [AtomType] -> ByteString
forall a. Serialise a => a -> ByteString
serialise (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func),
                                ByteString
bodyBin
                               ]
  where
    bodyBin :: ByteString
bodyBin = case AtomFunction -> FunctionBody AtomFunctionBodyType
forall a. Function a -> FunctionBody a
funcBody AtomFunction
func of
                FunctionScriptBody AttributeName
mScript AtomFunctionBodyType
_ -> AttributeName -> ByteString
forall a. Serialise a => a -> ByteString
serialise AttributeName
mScript
                FunctionBuiltInBody AtomFunctionBodyType
_ -> ByteString
""
                FunctionObjectLoadedBody String
f String
m String
n AtomFunctionBodyType
_ -> (String, String, String) -> ByteString
forall a. Serialise a => a -> ByteString
serialise (String
f,String
m,String
n)
  
-- | Used to mark functions which are loaded externally from the server.      
externalAtomFunction :: AtomFunctionBodyType -> AtomFunctionBody
externalAtomFunction :: AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
externalAtomFunction = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. a -> FunctionBody a
FunctionBuiltInBody