module Run where
import Control.Monad ((=<<), forever)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.State
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>), Last(..))
import qualified Data.Sequence as S
import Data.Sequence (Seq, (<|), ViewL(..))
import Data.Text (Text)
import Types
import Parse
import PSNum
pop :: Endsay Object
pop = Endsay $ do
st <- lift get
let x :< xs = S.viewl (isOpStack st)
lift $ put st { isOpStack = xs }
return x
push :: Object -> Endsay ()
push o = Endsay $ lift $ modify (\ s -> s { isOpStack = o <| isOpStack s })
pushObject :: ParsedObject -> Endsay ()
pushObject (POInteger n) = push (OInteger n)
pushObject (POReal n) = push (OReal n)
pushObject (PORadix _ n) = push (OInteger n)
pushObject (POString t) = push (OString t)
pushObject (POByteString t) = return ()
pushObject (POSymbol t) = push (OName t)
pushObject (POName t) = runCommand t
runCommand :: Text -> Endsay ()
runCommand t = do
obj <- findName t
case obj of
Nothing -> liftIO $ putStrLn "Name not found"
Just (OBuiltInOperator (BuiltIn b)) -> b
runEndsay :: Text -> Endsay a -> IO (Either ESErr a, InterpreterState)
runEndsay t (Endsay mote) =
runStateT (runExceptT mote) (initialInterpreterState t)
-- runStateT (runInterp mote) (runStateT (initialInterpreterState t) (runInterp mote))
findName :: Text -> Endsay (Maybe Object)
findName t = do
InterpreterState { isDictStack = ds } <- Endsay $ lift get
return $ getLast $ foldr (\ d r -> Last (HM.lookup t d) <> r) (Last Nothing) ds
step :: Endsay ()
step = do
st <- Endsay $ lift get
case pNextParsedObject (isParseState st) of
Left err -> Endsay $ throwE (ESErr "unable to parse another thing")
Right (po, st') -> do
pushObject po
Endsay $ lift $ modify $ \ s -> s { isParseState = st' }
run :: Endsay ()
run = forever step
initialInterpreterState :: Text -> InterpreterState
initialInterpreterState t = InterpreterState
{ isSource = t
, isParseState = initialParserState t
, isOpStack = S.empty
, isDictStack = S.singleton $ basicDict
, isExecStack = S.empty
}
builtin :: Endsay () -> Object
builtin = OBuiltInOperator . BuiltIn
basicDict :: HashMap Text Object
basicDict = HM.fromList
[ ("add", builtin $ do
x <- toPSNum =<< pop
y <- toPSNum =<< pop
push (fromPSNum (x + y))
)
, ("sub", builtin $ do
x <- toPSNum =<< pop
y <- toPSNum =<< pop
push (fromPSNum (x - y))
)
, ("mul", builtin $ do
x <- toPSNum =<< pop
y <- toPSNum =<< pop
push (fromPSNum (x * y))
)
, ("lt", builtin $ do
x <- toPSNum =<< pop
y <- toPSNum =<< pop
push (OBool (x < y))
)
, ("gt", builtin $ do
x <- toPSNum =<< pop
y <- toPSNum =<< pop
push (OBool (x > y))
)
, ("dup", builtin $ do
x <- pop
push x
push x
)
, ("exch", builtin $ do
x <- pop
y <- pop
push x
push x
)
, ("=", builtin $ pop >>= liftIO . print)
]