eval agian
This commit is contained in:
+108
-120
@@ -9,24 +9,27 @@ module Gyehoek.CPS.Eval
|
||||
, eGrammar
|
||||
) where
|
||||
|
||||
import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
|
||||
import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import Control.Lens
|
||||
import Control.Lens hiding (assign)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.Show.Functions ()
|
||||
import qualified Data.HashMap.Strict as H
|
||||
import Gyehoek.Prelude
|
||||
import Gyehoek.Prelude hiding (assign)
|
||||
import Debug.Pretty.Simple
|
||||
import Gyehoek.Jalmot
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
import Control.Monad.Cont
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import GHC.Generics (Generically(..))
|
||||
import Gyehoek.Sexp ((:-)(..))
|
||||
import Data.List (nub, mapAccumR)
|
||||
import Data.List (nub, mapAccumR, compareLength)
|
||||
import Data.HashSet.Lens (setOf)
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.IntMap.Strict qualified as IM
|
||||
import Data.Monoid
|
||||
import Control.Monad.State
|
||||
import Data.Traversable (for)
|
||||
import Data.Foldable (traverse_)
|
||||
|
||||
|
||||
newtype Loc = MkLoc { getLoc :: Int }
|
||||
@@ -37,11 +40,17 @@ data Store = MkStore
|
||||
{ nextLoc :: Loc
|
||||
, heap :: IntMap E
|
||||
}
|
||||
deriving stock (Show, Generic, Data)
|
||||
deriving stock (Show, Generic)
|
||||
|
||||
type instance Index Store = Loc
|
||||
type instance IxValue Store = E
|
||||
|
||||
instance Ixed Store where ix (MkLoc j) = #heap . ix j
|
||||
instance At Store where at (MkLoc j) = #heap . at j
|
||||
|
||||
emptyStore :: Store
|
||||
emptyStore = MkStore
|
||||
{ nextLoc = 0
|
||||
{ nextLoc = MkLoc 0
|
||||
, heap = mempty
|
||||
}
|
||||
|
||||
@@ -67,57 +76,45 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc
|
||||
updates :: Foldable f => f (Loc, E) -> Store -> Store
|
||||
updates = alaf Endo foldMap (uncurry update)
|
||||
|
||||
fetch :: Loc -> Store -> E
|
||||
fetch (MkLoc loc) st = st ^?! #heap . ix loc
|
||||
fetch :: Loc -> M r E
|
||||
fetch (MkLoc loc) = gets (^?! #heap . ix loc)
|
||||
|
||||
new :: Store -> (Store, Loc)
|
||||
new st = (st & #nextLoc %~ succ, st.nextLoc)
|
||||
new :: M r Loc
|
||||
new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
|
||||
|
||||
new' :: E -> Store -> (Store, Loc)
|
||||
new' e st = (update l e st', l)
|
||||
where
|
||||
(st',l) = new st
|
||||
new' :: E -> M r Loc
|
||||
new' e = state \st ->
|
||||
( st.nextLoc
|
||||
, st & #nextLoc %~ succ & at st.nextLoc ?~ e
|
||||
)
|
||||
|
||||
news' :: Traversable t => t E -> Store -> (Store, Loc)
|
||||
news' es st = mapAccumR _ st es
|
||||
where
|
||||
(st',l) = new st
|
||||
defines :: Traversable t => t (Name, E) -> M Answer Env
|
||||
defines = alaf Ap foldMap \(name,e) -> do
|
||||
l <- new' e
|
||||
pure $ bind name l
|
||||
|
||||
var :: HasCallStack => Env -> Name -> Loc
|
||||
var g x = g ^?! ix x
|
||||
var :: HasCallStack => Env -> Name -> M Answer Loc
|
||||
var g x = case g ^. at x of
|
||||
Just l -> pure l
|
||||
Nothing -> wrong [i|unbound variable #{x}|]
|
||||
|
||||
type CmdCont = Store -> Answer
|
||||
type ExpCont = List E -> CmdCont
|
||||
|
||||
type M r = ContT r (State Store)
|
||||
|
||||
data Answer
|
||||
= AnswerValues Store (List E)
|
||||
| AnswerError Text
|
||||
deriving (Show, Generic, Data)
|
||||
= AnswerValues (List E)
|
||||
| AnswerError AJalmot
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Mutability
|
||||
= Mut
|
||||
| NoMut
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
wrong :: Text -> CmdCont
|
||||
wrong = const . AnswerError
|
||||
|
||||
single :: (E -> CmdCont) -> ExpCont
|
||||
single k = \case
|
||||
[x] -> k x
|
||||
_ -> wrong "wrong number of return values"
|
||||
|
||||
send :: E -> ExpCont -> CmdCont
|
||||
send e k = k [e]
|
||||
|
||||
-- | Continue with the value located at a given 'Loc'.
|
||||
hold :: Loc -> ExpCont -> CmdCont
|
||||
hold loc k st = send (fetch loc st) k st
|
||||
|
||||
tievals :: Traversable t => t E -> (t Loc -> CmdCont) -> CmdCont
|
||||
tievals es f st0 = f ls stn
|
||||
where
|
||||
(stn,ls) = mapAccumR (flip new') st0 es
|
||||
wrong :: Text -> M Answer a
|
||||
wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
|
||||
|
||||
bind :: Name -> Loc -> Env
|
||||
bind k = MkEnv . H.singleton k
|
||||
@@ -125,13 +122,19 @@ bind k = MkEnv . H.singleton k
|
||||
extends :: Foldable f => f (Name, Loc) -> Env -> Env
|
||||
extends xs g = g <> foldMap (uncurry bind) xs
|
||||
|
||||
assign :: Loc -> E -> M Answer ()
|
||||
assign l e = do
|
||||
use (at l) >>= \case
|
||||
Just _ -> at l ?= e
|
||||
Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
|
||||
|
||||
|
||||
|
||||
-- | The denotation of an expressed value.
|
||||
data E
|
||||
= ESymbol Text
|
||||
| ECharacter Char
|
||||
| EInteger Int
|
||||
| EInt Int
|
||||
| EBool Bool
|
||||
| EUndefined
|
||||
| EUnspecified
|
||||
@@ -139,19 +142,19 @@ data E
|
||||
| EPair Loc Loc Mutability
|
||||
| EVec (List Loc) Mutability
|
||||
| EString (List Loc) Mutability
|
||||
| EProcedure Loc Procedure
|
||||
deriving stock (Show, Generic, Data)
|
||||
| EProcedure Procedure
|
||||
deriving stock (Show, Generic)
|
||||
|
||||
type Procedure = List E -> DynPoints -> ExpCont -> CmdCont
|
||||
type Procedure = List E -> DynPoints -> M Answer (List E)
|
||||
|
||||
eGrammar :: Store -> S.DatumGrammar E
|
||||
eGrammar st = S.partialOsi (const . Left $ mempty) go
|
||||
where
|
||||
gofetch x = go $ fetch x st
|
||||
gofetch x = go $ st ^?! ix x
|
||||
go = \case
|
||||
ESymbol s -> S.Symbol s
|
||||
ECharacter c -> S.Character c
|
||||
EInteger n -> S.Number (fromIntegral n)
|
||||
EInt n -> S.Number (fromIntegral n)
|
||||
EBool b -> S.Boolean b
|
||||
EUndefined -> S.Unreadable "#<undefined>"
|
||||
EUnspecified -> S.Unreadable "#<unspecified>"
|
||||
@@ -165,88 +168,73 @@ data DynPoints = MkDynPoints
|
||||
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
evalVal :: Env -> Val -> M Answer E
|
||||
|
||||
|
||||
evalVal g (ValVar x) = var g x >>= fetch
|
||||
|
||||
procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont
|
||||
procedure = _
|
||||
evalVal g (ValImm imm) = pure case imm of
|
||||
ImmInt n -> EInt n
|
||||
ImmBool b -> EBool b
|
||||
ImmUndefined -> EUndefined
|
||||
|
||||
evalVal :: Env -> Val -> ExpCont -> CmdCont
|
||||
evalVal g (ValVar x) k = hold (var g x) $ single \case
|
||||
EUndefined -> wrong "undefined variable"
|
||||
e -> send e k
|
||||
evalKexp :: Env -> Kexp -> M Answer E
|
||||
evalKexp g (KexpVar x) = var g x >>= fetch
|
||||
evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
|
||||
|
||||
evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
|
||||
evalVal1 g v k = evalVal g v (single k)
|
||||
|
||||
evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
|
||||
|
||||
evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
|
||||
|
||||
evalKexp g (KexpKappa kap) k = evalAbs g (AbsKappa kap) k
|
||||
|
||||
evalAbs :: Env -> Abs -> ExpCont -> CmdCont
|
||||
evalAbs g (MkAbs formals mtail e) k st = send ab k st'
|
||||
where
|
||||
(st',l) = new' EUnspecified st
|
||||
ab = EProcedure l \args dps k' ->
|
||||
tievals args \argLocs ->
|
||||
let argEnv = zip (formals ++ foldMap (:[]) mtail) argLocs
|
||||
g' = g <> foldMap (uncurry bind) argEnv
|
||||
in eval g' dps e k'
|
||||
|
||||
eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
|
||||
|
||||
eval g dps (ExpLetRec bs e) k = \st0 ->
|
||||
evalAbs :: Env -> Abs -> M Answer E
|
||||
evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
|
||||
let
|
||||
rhss = bs ^.. each . _2
|
||||
(st',ls) = mapAccumR (\st _ -> new st) st0 bs
|
||||
g' = g & extends (zip (bs ^.. each . _1) ls)
|
||||
f :: List E -> CmdCont
|
||||
f = \rhss' -> eval g' dps e k . updates (zip ls rhss')
|
||||
in telescope (\ab -> evalAbs g' ab . single) rhss f st'
|
||||
formals' = formals ++ foldMap (:[]) ktail
|
||||
lformals = length formals'
|
||||
lxs = length xs
|
||||
in if lformals /= lxs
|
||||
then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
|
||||
else do
|
||||
ls <- xs & traverse new'
|
||||
let g' = g & extends (zip formals' ls)
|
||||
eval g' dps e
|
||||
|
||||
eval g dps (ExpJump f xs ktail) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
telescope (\ke -> evalKexp g ke . single) (ktail ^.. each) \ktail' ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp xs' dps k
|
||||
_ -> wrong "bad procedure"
|
||||
eval :: Env -> DynPoints -> Exp -> M Answer (List E)
|
||||
|
||||
eval g dps (ExpContinue f xs) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp xs' dps k
|
||||
_ -> wrong "bad procedure"
|
||||
eval g dps (ExpJump f xs ktail) = do
|
||||
f' <- evalVal g f
|
||||
xs' <- traverse (evalVal g) xs
|
||||
ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
|
||||
case f' of
|
||||
EProcedure p -> p (xs' ++ ktail') dps
|
||||
_ -> wrong "bad procedure"
|
||||
|
||||
eval g dps (ExpApply f xs ktail) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
evalKexp g ktail . single $ \ktail' ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp (xs' ++ [ktail']) dps k
|
||||
_ -> wrong "bad procedure"
|
||||
eval g dps (ExpLetRec bs e) = do
|
||||
ls <- for bs . const $ new' EUndefined
|
||||
let g' = g & extends (zip (bs ^.. each . _1) ls)
|
||||
bs' <- forOf (each . _2) bs (evalAbs g')
|
||||
traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
|
||||
eval g' dps e
|
||||
|
||||
eval g dps e = error [i|unimplemented #{e}|]
|
||||
|
||||
|
||||
|
||||
prim_halt :: Procedure
|
||||
prim_halt xs _dps _k st = AnswerValues st xs
|
||||
|
||||
setup :: (Env -> CmdCont) -> CmdCont
|
||||
setup k = tievals (defs ^.. each) _
|
||||
where
|
||||
defs :: HashMap Name E
|
||||
defs =
|
||||
[ ("halt", EProcedure _ prim_halt)
|
||||
]
|
||||
|
||||
evalExp :: Jalmot :> es => Exp -> Eff es _
|
||||
evalExp e = _
|
||||
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es (List E)
|
||||
evalProgram (MkProgram lam) = _
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
|
||||
evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
|
||||
(AnswerError jm, _) -> throwError jm
|
||||
(AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
|
||||
where
|
||||
run f = (`runState` emptyStore) . (`runContT` f) $ do
|
||||
g <- setup
|
||||
eval g MkDynPoints (ExpLetRec
|
||||
[("_start",AbsLambda lam)]
|
||||
(ExpApply (ValVar "_start") [] (KexpVar "halt")))
|
||||
|
||||
|
||||
|
||||
setup :: M Answer Env
|
||||
setup = defines @List
|
||||
[ ("halt", EProcedure prim_halt)
|
||||
]
|
||||
|
||||
prim_halt :: Procedure
|
||||
prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs
|
||||
|
||||
@@ -31,6 +31,7 @@ data AJalmot
|
||||
= ReaderError (ParseErrorBundle Text Void)
|
||||
| GrammarError (Grammar.ErrorMessage Ann)
|
||||
| VMError Text
|
||||
| EvalError Text
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
|
||||
@@ -66,6 +67,7 @@ instance Exception AJalmot where
|
||||
& layoutPretty defaultLayoutOptions
|
||||
& renderString
|
||||
VMError err -> [i|#{err}|]
|
||||
EvalError err -> [i|#{err}|]
|
||||
|
||||
instance Exception AJalmotCS where
|
||||
backtraceDesired = const False
|
||||
|
||||
Reference in New Issue
Block a user