{-# LANGUAGE OverloadedStrings #-}
module Funcons.Core.Computations.AbnormalBuiltin where
import Funcons.EDSL
import Funcons.Operations hiding (Values,libFromList)
library = libFromList
[("handle-thrown",NonStrictFuncon stepHandle_thrown)
,("handle-return",NonStrictFuncon stepHandle_return)
,("else", NonStrictFuncon stepElse)
]
handle_thrown_ fargs = FApp "handle-thrown" (fargs)
stepHandle_thrown fargs =
evalRules [rewrite1] [step1]
where rewrite1 = do
let env = emptyEnv
env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env
rewriteTermTo (TVar "V") env
step1 = do
let env = emptyEnv
env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env
env <- getControlPatt "abrupted" (Nothing) env
(env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") [PMetaVar "X'"] env))
case __varabrupted of
Nothing -> stepTermTo (TApp "handle-thrown" [TVar "X'",TVar "Y"]) env
Just (ADTVal "thrown" [v]) -> stepTermTo (TApp "give" [TFuncon v, TVar "Y"]) env
Just v -> do raiseSignal "abrupted" v
stepTermTo (TApp "handle-thrown" [TVar "X'",TVar "Y"]) env
stepHandle_return fargs =
evalRules [rewrite1] [step1]
where rewrite1 = do
let env = emptyEnv
env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values")] env
rewriteTermTo (TVar "V") env
step1 = do
let env = emptyEnv
env <- lifted_fsMatch fargs [PMetaVar "X"] env
env <- getControlPatt "abrupted" (Nothing) env
(env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") [PMetaVar "X'"] env))
case __varabrupted of
Nothing -> stepTermTo (TApp "handle-return" [TVar "X'"]) env
Just (ADTVal "returned" [v]) -> stepTo v
Just v -> do raiseSignal "abrupted" v
stepTermTo (TApp "handle-return" [TVar "X'"]) env
stepElse fargs =
evalRules [rewrite1,rewrite2] [step1]
where rewrite1 = do
let env = emptyEnv
env <- fsMatch fargs [PAnnotated (PMetaVar "V") (TName "values"),PMetaVar "Y"] env
rewriteTermTo (TVar "V") env
rewrite2 = do
let env = emptyEnv
env <- fsMatch fargs [PMetaVar "X",PMetaVar "Y",PSeqVar "Z+" PlusOp] env
rewriteTermTo (TApp "else" [TVar "X",TApp "else" [TVar "Y",TVar "Z+"]]) env
step1 = do
let env = emptyEnv
env <- lifted_fsMatch fargs [PMetaVar "X",PMetaVar "Y"] env
env <- getControlPatt "abrupted" (Nothing) env
(env,[__varabrupted]) <- receiveSignals ["abrupted"] (withControlTerm "abrupted" (Nothing) env (premise (TVar "X") [PMetaVar "X'"] env))
case __varabrupted of
Nothing -> stepTermTo (TApp "else" [TVar "X'",TVar "Y"]) env
Just (ADTVal "failed" _) -> stepTermTo (TVar "Y") env
Just v -> do raiseSignal "abrupted" v
stepTermTo (TApp "else" [TVar "X'",TVar "Y"]) env