#include "BerpDebug.h"
module Berp.Base.Prims
( (=:), stmt, ifThenElse, ret, pass, break
, continue, while, whileElse, for, forElse, ifThen, (@@), tailCall
, read, var, binOp, setattr, callMethod, callSpecialMethod, subs
, try, tryElse, tryFinally, tryElseFinally, except, exceptDefault
, raise, reRaise, raiseFrom, primitive, generator, yield, generatorNext
, def, lambda, mkGenerator, printObject, topVar, Applicative.pure
, pureObject, showObject, returningProcedure, pyCallCC ) where
import Prelude hiding (break, read, putStr)
import Control.Monad.State (gets)
import Control.Monad.Cont (callCC)
import Berp.Base.LiftedIO as LIO (readIORef, writeIORef, newIORef, putStr)
#ifdef DEBUG
import Berp.Base.LiftedIO as LIO (putStrLn)
#endif
import qualified Control.Applicative as Applicative (pure)
import Control.Applicative ((<$>))
import Data.Maybe (maybe)
import Berp.Base.Ident (Ident)
import Berp.Base.SemanticTypes (Object (..), ObjectRef, Procedure, Eval, EvalState(..), ControlStack(..), Arity)
import Berp.Base.Truth (truth)
import Berp.Base.Object
( typeOf, dictOf, lookupAttribute, lookupSpecialAttribute, objectEquality)
import Berp.Base.Hash (Hashed, hashedStr)
import Berp.Base.ControlStack
import Berp.Base.StdNames (docName, strName)
import Berp.Base.Exception (RuntimeError (..), throw)
import Berp.Base.StdTypes.Function (function)
import Berp.Base.HashTable as Hash (stringInsert)
import Berp.Base.StdTypes.None (none)
import Berp.Base.StdTypes.Bool (true, false)
import Berp.Base.StdTypes.Generator (generator)
import Berp.Base.Builtins.Exceptions (stopIteration, typeError)
pureObject :: Object -> Eval Object
pureObject = Applicative.pure
primitive :: Arity -> Procedure -> Object
primitive arity = function arity . returningProcedure
returningProcedure :: Procedure -> Procedure
returningProcedure proc args = do
result <- proc args
ret result
infix 1 =:
infixl 8 @@
topVar :: Ident -> IO ObjectRef
topVar s = newIORef (error $ "undefined variable:" ++ s)
var :: Ident -> Eval ObjectRef
var s = newIORef (error $ "undefined variable: " ++ s)
read :: ObjectRef -> Eval Object
read = readIORef
ret :: Object -> Eval Object
ret obj = do
stack <- unwind isProcedureCall
procedure_return stack obj
pass :: Eval Object
pass = return none
break :: Eval Object
break = do
stack <- unwindPastWhileLoop
loop_end stack
continue :: Eval Object
continue = do
stack <- unwindUpToWhileLoop
loop_start stack
(=:) :: ObjectRef -> Object -> Eval Object
ident =: obj = writeIORef ident obj >> return none
(@@) :: Object -> [Object] -> Eval Object
obj @@ args = do
case obj of
Function { object_procedure = proc, object_arity = arity }
| arity == 1 || arity == length args ->
callProcedure proc args
| otherwise -> raise typeError
Type { object_constructor = proc } -> callProcedure proc args
_other -> raise typeError
callProcedure :: Procedure -> [Object] -> Eval Object
callProcedure proc args =
callCC $ \ret -> do
push $ ProcedureCall ret
proc args
tailCall :: Object -> [Object] -> Eval Object
tailCall obj args = do
case obj of
Function { object_procedure = proc, object_arity = arity }
| arity == 1 || arity == length args -> proc args
| otherwise -> raise typeError
Type { object_constructor = proc } -> proc args
_other -> raise typeError
ifThenElse :: Eval Object -> Eval Object -> Eval Object -> Eval Object
ifThenElse condComp trueComp falseComp = do
cond <- condComp
if truth cond then trueComp else falseComp
ifThen :: Eval Object -> Eval Object -> Eval Object
ifThen condComp trueComp = do
cond <- condComp
if truth cond then trueComp else pass
for :: ObjectRef -> Object -> Eval Object -> Eval Object
for var exp body = forElse var exp body pass
forElse :: ObjectRef -> Object -> Eval Object -> Eval Object -> Eval Object
forElse var expObj suite1 suite2 = do
iterObj <- callMethod expObj $(hashedStr "__iter__") []
cond <- newIORef true
let tryBlock = do nextObj <- callMethod iterObj $(hashedStr "__next__") []
writeIORef var nextObj
suite1
let handler e = except e stopIteration ((writeIORef cond false) >> pass) (raise e)
let whileBlock = try tryBlock handler
whileElse (readIORef cond) whileBlock suite2
while :: Eval Object -> Eval Object -> Eval Object
while cond loopBlock = whileElse cond loopBlock pass
whileElse :: Eval Object -> Eval Object -> Eval Object -> Eval Object
whileElse cond loopBlock elseBlock = do
callCC $ \end -> do
let afterLoop = end none
loop = do condVal <- cond
if truth condVal
then do
loopBlock
loop
else do
unwindPastWhileLoop
elseBlock
afterLoop
push $ WhileLoop loop afterLoop
loop
stmt :: Eval Object -> Eval Object
stmt = id
binOp :: Object -> Object -> (Object -> t) -> (t -> t -> r) -> (r -> Eval Object) -> Eval Object
binOp left right project fun build
= build (project left `fun` project right)
setattr :: Object -> Hashed String -> Object -> Eval Object
setattr target attribute value
| Just dict <- dictOf target = do
let hashTable = object_hashTable dict
Hash.stringInsert attribute value $ hashTable
return value
| otherwise = error $ "setattr on object unimplemented: " ++ show (target, attribute)
callMethod :: Object -> Hashed String -> [Object] -> Eval Object
callMethod object ident args = do
proc <- lookupAttribute object ident
proc @@ args
callSpecialMethod :: Object -> Hashed String -> [Object] -> Eval Object
callSpecialMethod object ident args = do
proc <- lookupSpecialAttribute object ident
proc @@ args
subs :: Object -> Object -> Eval Object
subs obj subscript = callMethod obj $(hashedStr "__getitem__") [subscript]
try :: Eval Object -> (Object -> Eval Object) -> Eval Object
try tryComp handler = tryWorker tryComp handler pass Nothing
tryElse :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object
tryElse tryComp handler elseComp =
tryWorker tryComp handler elseComp Nothing
tryFinally :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object
tryFinally tryComp handler finallyComp
= tryWorker tryComp handler pass (Just finallyComp)
tryElseFinally :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Eval Object -> Eval Object
tryElseFinally tryComp handler elseComp finallyComp
= tryWorker tryComp handler elseComp (Just finallyComp)
tryWorker :: Eval Object -> (Object -> Eval Object) -> Eval Object -> Maybe (Eval Object) -> Eval Object
tryWorker tryComp handler elseComp maybeFinallyComp = do
callCC $ \afterTry -> do
push (ExceptionHandler
(Just $ \obj -> do
handler obj
afterTry none)
maybeFinallyComp)
tryComp
nullifyTopHandler
elseComp
unwind isExceptionHandler
pass
except :: Object -> Object -> Eval Object -> Eval Object -> Eval Object
except exceptionObj baseObj match noMatch = do
BELCH("compatible check: " ++ show (exceptionObj, baseObj))
isCompatible <- compatibleException exceptionObj baseObj
if isCompatible
then match
else noMatch
where
compatibleException :: Object -> Object -> Eval Bool
compatibleException exceptionObj baseObj = do
let typeOfException = typeOf exceptionObj
objectEquality typeOfException baseObj
exceptDefault :: Eval Object -> Eval Object -> Eval Object
exceptDefault match _noMatch = match
raise :: Object -> Eval Object
raise obj = do
BELCH("Raising: " ++ show obj)
IF_DEBUG(dumpStack)
exceptionObj <- case obj of
Type { object_constructor = cons } ->
callProcedure cons []
other -> return other
stack <- gets control_stack
handleFrame exceptionObj stack
where
handleFrame :: Object -> ControlStack -> Eval Object
handleFrame exceptionObj EmptyStack = do
str <- showObject exceptionObj
throw $ UncaughtException str
handleFrame exceptionObj (ExceptionHandler { exception_handler = handler, exception_finally = finally }) = do
case handler of
Nothing -> do
pop
maybe pass id finally
raise exceptionObj
Just handlerAction -> do
nullifyTopHandler
handlerAction exceptionObj
handleFrame exceptionObj (GeneratorCall { generator_object = genObj }) = do
writeIORef (object_continuation genObj) (raise stopIteration)
pop >> raise exceptionObj
handleFrame exceptionObj _other = do
pop >> raise exceptionObj
reRaise :: Eval Object
reRaise = error "reRaise not implemented"
raiseFrom :: Object -> Object -> Eval Object
raiseFrom = error "raiseFrom not implemented"
yield :: Object -> Eval Object
yield obj = do
BELCH("Yielding " ++ show obj)
callCC $ \next -> do
generatorYield <- unwindYieldContext (next none)
generatorYield obj
generatorNext :: [Object] -> Eval Object
generatorNext (obj:_) = do
result <- callCC $ \next ->
case obj of
Generator {} -> do
BELCH("Starting generator")
stackContext <- readIORef $ object_stack_context obj
push (stackContext . GeneratorCall next obj)
BELCH("calling continuation")
action <- readIORef $ object_continuation obj
action
BELCH("raising exception")
raise stopIteration
_other -> error "next applied to object which is not a generator"
ret result
generatorNext [] = error "Generator applied to no arguments"
def :: ObjectRef -> Arity -> Object -> ([ObjectRef] -> Eval Object) -> Eval Object
def ident arity docString fun = do
let procedureObj = function arity closure
setattr procedureObj docName docString
writeIORef ident procedureObj
return none
where
closure :: Procedure
closure params = do
argsRefs <- mapM newIORef params
fun argsRefs
lambda :: Arity -> ([ObjectRef] -> Eval Object) -> Eval Object
lambda arity fun =
return $ function arity closure
where
closure :: Procedure
closure params = do
argsRefs <- mapM newIORef params
fun argsRefs
mkGenerator :: Eval Object -> Eval Object
mkGenerator cont = do
generatorObj <- generator cont
ret generatorObj
printObject :: Object -> Eval ()
printObject obj = do
str <- showObject obj
putStr str
showObject :: Object -> Eval String
showObject obj@(String {}) = return ("'" ++ object_string obj ++ "'")
showObject obj = object_string <$> callSpecialMethod obj strName []
pyCallCC :: Object -> Eval Object
pyCallCC fun =
callCC $ \ret -> do
context <- getControlStack
let cont = function 1 $ \(obj:_) -> do
setControlStack context
ret obj
fun @@ [cont]