#include "BerpDebug.h"
module Berp.Base.Class (klass) where
import Berp.Base.LiftedIO (liftIO, MonadIO, writeIORef, readIORef)
import Berp.Base.Ident
import Berp.Base.SemanticTypes (Eval, Object (..), ObjectRef)
#ifdef DEBUG
import Berp.Base.Prims (printObject)
#endif
import Berp.Base.Hash (Hashed)
import Berp.Base.Attributes (mkAttributes)
import Berp.Base.StdTypes.Type (newType)
import Berp.Base.StdTypes.String (string)
import Berp.Base.StdTypes.Tuple (tuple)
import Berp.Base.StdTypes.None (none)
import Berp.Base.StdTypes.Object (object)
klass :: Ident -> ObjectRef -> [Object] -> Eval [(Hashed String, ObjectRef)] -> Eval Object
klass className ident srcBases attributesComp = do
let trueBases = if null srcBases then [object] else srcBases
attributes <- attributesComp
attributesObjects <- mapM getIdentObj attributes
classDict <- mkAttributes attributesObjects
typeObject <- liftIO $ newType [string className, tuple trueBases, classDict]
writeIORef ident $ typeObject
IF_DEBUG((printObject $ object_mro typeObject) >> putStr "\n")
return none
where
getIdentObj :: MonadIO m => (a, ObjectRef) -> m (a, Object)
getIdentObj (ident, ref) = do
obj <- readIORef ref
return (ident, obj)