module Interpreter (
addBreak, removeBreak, toggleBreak,
interpret, step, reset
)
where
import qualified Graphics.UI.Gtk as Gtk
import qualified InterfaceDT as IDT
import qualified TextAreaContent as TAC
import qualified Lexer
import qualified Data.Map as Map
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.List
import qualified Data.Foldable
type Funcmap = Map.Map String IDT.PositionedGrid
getCurrentText buffer = do
start <- Gtk.textBufferGetStartIter buffer
end <- Gtk.textBufferGetEndIter buffer
Gtk.textBufferGetText buffer start end True
checkStep tac flag action = do
cnt <- readIORef (TAC.context tac)
isBlocked <- blocked tac
let flags = TAC.railFlags cnt
if flag `elem` flags && null (TAC.funcStack cnt)
then showError tac "Please reset, before you change the execution mode"
else do
unless (TAC.Interpret `elem` flags) $ writeIORef (TAC.context tac) cnt{TAC.railFlags = TAC.Interpret:flags}
if TAC.Blocked `elem` flags
then do
putStrLn "is blocked"
unless isBlocked $ do
putStrLn "unblock"
inputAfterBlock tac
writeIORef (TAC.context tac) cnt{TAC.railFlags = delete TAC.Blocked flags}
else action
addBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()
addBreak tac position = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.breakMap = Map.insert position True (TAC.breakMap cnt)}
removeBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()
removeBreak tac position = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.breakMap = Map.delete position (TAC.breakMap cnt)}
toggleBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()
toggleBreak tac position = do
cnt <- readIORef (TAC.context tac)
if isNothing $ Map.lookup position (TAC.breakMap cnt)
then addBreak tac position
else removeBreak tac position
reset :: TAC.TextAreaContent -> IO ()
reset tac = do
abortExecution tac
Gtk.textBufferSetText (snd $ TAC.buffer tac) ""
Gtk.textBufferSetText (fst $ TAC.buffer tac) ""
abortExecution :: TAC.TextAreaContent -> IO ()
abortExecution tac = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) (TAC.IC [] [] (TAC.breakMap cnt) 0 (-1,-1) [])
init :: TAC.TextAreaContent -> IO ()
init tac = do
reset tac
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.funcStack = [("main", Lexer.start, Map.empty)]}
blocked :: TAC.TextAreaContent -> IO Bool
blocked tac = do
cnt <- readIORef (TAC.context tac)
let offset = TAC.inputOffset cnt
buffer = fst $ TAC.buffer tac
currentText <- getCurrentText buffer
putStrLn $ "off:" ++ show offset ++ "; "++ show (length currentText)
return $ offset > length currentText
showError :: TAC.TextAreaContent -> String -> IO ()
showError tac string = do
showMessage tac ("Error: " ++ string)
abortExecution tac
showMessage :: TAC.TextAreaContent -> String -> IO ()
showMessage tac message = showRawMessage (message ++ "\n") (snd $ TAC.buffer tac)
showRawMessage :: String -> Gtk.TextBuffer -> IO ()
showRawMessage message buffer = do
end <- Gtk.textBufferGetEndIter buffer
Gtk.textBufferInsert buffer end message
updateCurIPPos :: TAC.TextAreaContent -> Funcmap -> IO ()
updateCurIPPos tac fmap = do
cnt <- readIORef (TAC.context tac)
unless (null $ TAC.funcStack cnt) $ do
let ((fname, ip, _):_) = TAC.funcStack cnt
offset = snd $ fromJust $ Map.lookup fname fmap
writeIORef (TAC.context tac) cnt{TAC.curIPPos = (Lexer.posx ip, Lexer.posy ip + offset)}
interpret' :: TAC.TextAreaContent -> Funcmap -> IO ()
interpret' tac funcmap = do
dostep tac funcmap
updateCurIPPos tac funcmap
stop <- needsHalt tac funcmap
unless stop $ interpret' tac funcmap
interpret :: TAC.TextAreaContent -> IO ()
interpret tac = checkStep tac TAC.Step $ do
putStrLn "noBlock"
funcmap <- getFunctions tac
interpret' tac funcmap
step tac = checkStep tac TAC.Interpret $ do
funcmap <- getFunctions tac
dostep tac funcmap
updateCurIPPos tac funcmap
inputAfterBlock :: TAC.TextAreaContent -> IO ()
inputAfterBlock tac = do
cnt <- readIORef (TAC.context tac)
let offset = TAC.inputOffset cnt
let buffer = fst $ TAC.buffer tac
currentText <- getCurrentText buffer
putStrLn "read"
let char = currentText !! offset
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString [char]:TAC.dataStack cnt}
dostep :: TAC.TextAreaContent -> Funcmap -> IO ()
dostep tac funcmap = do
cnt <- readIORef (TAC.context tac)
let fstack = TAC.funcStack cnt
when (null fstack) (Interpreter.init tac)
cnt <- readIORef (TAC.context tac)
let ((fname, ip, vars):xs) = TAC.funcStack cnt
if isNothing $ Map.lookup fname funcmap
then showError tac $ "Function '" ++ fname ++ "' not found"
else do
let
grid = fst $ fromJust $ Map.lookup fname funcmap
tmpip = Lexer.step grid ip
(maylex, newip) = Lexer.parse grid tmpip
writeIORef (TAC.context tac) cnt{TAC.funcStack = (fname, newip, vars):xs}
Data.Foldable.forM_ maylex (perform tac funcmap)
perform :: TAC.TextAreaContent -> Funcmap -> IDT.Lexeme -> IO ()
perform tac _ IDT.Boom = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else
if not $ isString $ head $ TAC.dataStack cnt
then showError tac "Element on top of stack is no String"
else do
showMessage tac (show $ head $ TAC.dataStack cnt)
abortExecution tac
-- TODO
perform tac _ IDT.EOF = return ()
perform tac _ IDT.Input = do
cnt <- readIORef (TAC.context tac)
let offset = TAC.inputOffset cnt
writeIORef (TAC.context tac) cnt{TAC.inputOffset = succ offset}
isBlocked <- blocked tac
if isBlocked
then do
let flags = TAC.railFlags cnt
writeIORef (TAC.context tac) cnt{TAC.railFlags = TAC.Blocked:flags}
putStrLn "blocken"
return ()
else do
let buffer = fst $ TAC.buffer tac
start <- Gtk.textBufferGetStartIter buffer
end <- Gtk.textBufferGetEndIter buffer
currentText <- Gtk.textBufferGetText buffer start end True
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString [currentText !! offset]:TAC.dataStack cnt}
perform tac _ IDT.Output = do
cnt <- readIORef (TAC.context tac)
let dataSt = TAC.dataStack cnt
if null dataSt
then showError tac "Empty Stack"
else if (\(TAC.RailString _:_) -> True) dataSt
then do
showRawMessage ((\(TAC.RailString t:_) -> t) dataSt) (snd $ TAC.buffer tac)
writeIORef (TAC.context tac) cnt{TAC.dataStack = tail (TAC.dataStack cnt)}
else showError tac "Element on top of the stack is no String"
perform tac _ IDT.Underflow = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.dataStack = (TAC.RailString $ show $ length $ TAC.dataStack cnt):TAC.dataStack cnt}
perform tac _ IDT.RType = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else writeIORef (TAC.context tac) cnt{TAC.dataStack = typeOf (head $ TAC.dataStack cnt):tail (TAC.dataStack cnt)}
perform tac _ (IDT.Constant string) = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString string:TAC.dataStack cnt}
perform tac _ (IDT.Push string) = do
cnt <- readIORef (TAC.context tac)
let res = searchVar string (TAC.funcStack cnt)
if isNothing res
then showError tac ("Variable '" ++ string ++ "' not found")
else writeIORef (TAC.context tac) cnt{TAC.dataStack = fromJust res:TAC.dataStack cnt}
perform tac _ (IDT.Pop string) = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else do
let ((fname, ip, vars):xs) = TAC.funcStack cnt
nvars = Map.insert string (head $ TAC.dataStack cnt) vars
writeIORef (TAC.context tac) cnt{TAC.dataStack = tail $ TAC.dataStack cnt, TAC.funcStack = (fname, ip, nvars):xs}
perform tac _ (IDT.Call string) = do
cnt <- readIORef (TAC.context tac)
if null string
then
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else
if not $ isLambda $ head $ TAC.dataStack cnt
then showError tac "Wrong type on stack, string expected"
else do
let (TAC.RailLambda fn ip map:xs) = TAC.dataStack cnt
writeIORef (TAC.context tac) cnt{TAC.funcStack = (fn, ip, map):TAC.funcStack cnt, TAC.dataStack = xs}
else writeIORef (TAC.context tac) cnt{TAC.funcStack = (string, Lexer.start, Map.empty):TAC.funcStack cnt}
perform tac _ IDT.Add1 = performMath tac (+)
perform tac _ IDT.Divide = performMath tac div -- may be needed to adjust according to compiler
perform tac _ IDT.Multiply = performMath tac (*)
perform tac _ IDT.Remainder = performMath tac rem
perform tac _ IDT.Subtract = performMath tac (-)
perform tac _ IDT.Cut = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)
then showError tac "Not enough elements on stack"
else do
let (e1:e2:xs) = TAC.dataStack cnt
if not (isNumeric e1) || not (isString e2)
then showError tac "Wrong types on stack, number and string expected"
else do
let (TAC.RailString s1, TAC.RailString s2) = (e1, e2)
if length s2 > (read s1 :: Int)
then showError tac "Cut number bigger than string length"
else do
let (lres, rres) = splitAt (read s1 :: Int) s2
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString rres:TAC.RailString lres:xs}
perform tac _ IDT.Append = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)
then showError tac "Not enough elements on stack"
else do
let (e1:e2:xs) = TAC.dataStack cnt
if not (isString e1) || not (isString e2)
then showError tac "Wrong types on stack, strings expected"
else do
let (TAC.RailString s1, TAC.RailString s2) = (e1, e2)
res = TAC.RailString (s2 ++ s1)
writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}
perform tac _ IDT.Size = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else
if not $ isString $ head $ TAC.dataStack cnt
then showError tac "Wrong type on stack, string expected"
else do
let (TAC.RailString str:xs) = TAC.dataStack cnt
res = TAC.RailString $ show $ length str
writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}
perform tac _ IDT.Nil = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailList []:TAC.dataStack cnt}
perform tac _ IDT.Cons = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)
then showError tac "Not enough elements on stack"
else
if not $ isList $ head $ tail $ TAC.dataStack cnt
then showError tac "Wrong type on second position of stack, list expected"
else do
let (x:TAC.RailList lst:xs) = TAC.dataStack cnt
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailList (x:lst):xs}
perform tac _ IDT.Breakup = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else
if not $ isList $ head $ TAC.dataStack cnt
then showError tac "Wrong type on stack, list expected"
else do
let (TAC.RailList lst:xs) = TAC.dataStack cnt
if null lst
then showError tac "Empty list cannot be splitted"
else do
let (y:ys) = lst
writeIORef (TAC.context tac) cnt{TAC.dataStack = y:TAC.RailList ys:xs}
perform tac _ IDT.Greater = performMath tac (\x y -> if x > y then 1 else 0)
perform tac _ IDT.Equal = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)
then showError tac "Not enough elements on stack"
else do
let (e1:e2:xs) = TAC.dataStack cnt
res = TAC.RailString (if e1 == e2 then "1" else "0")
writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}
perform tac _ IDT.Finish = do
cnt <- readIORef (TAC.context tac)
writeIORef (TAC.context tac) cnt{TAC.funcStack = tail $ TAC.funcStack cnt, TAC.curIPPos = (-1, -1)}
perform tac fmap (IDT.Junction _) = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt)
then showError tac "Empty stack"
else
if not $ isBool $ head $ TAC.dataStack cnt
then showError tac "Wrong type on stack, boolean expected"
else do
let ((fname, ip, vars):xs) = TAC.funcStack cnt
(fip, tip) = Lexer.junctionturns (fst $ fromJust $ Map.lookup fname fmap) ip
nip = if head (TAC.dataStack cnt) == TAC.RailString "0" then fip else tip
writeIORef (TAC.context tac) cnt{TAC.dataStack = tail $ TAC.dataStack cnt, TAC.funcStack = (fname, nip, vars):xs}
perform tac _ (IDT.Lambda _) = do
cnt <- readIORef (TAC.context tac)
let ((fname, ip, vars):xs) = TAC.funcStack cnt
(lip, nip) = Lexer.lambdadirs ip
writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailLambda fname lip vars:TAC.dataStack cnt, TAC.funcStack = (fname, nip, vars):xs}
performMath :: TAC.TextAreaContent -> (Int -> Int -> Int) -> IO ()
performMath tac op = do
cnt <- readIORef (TAC.context tac)
if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)
then showError tac "Not enough elements on stack"
else do
let (e1:e2:xs) = TAC.dataStack cnt
if not (isNumeric e1) || not (isNumeric e2)
then showError tac "Wrong types on stack, numbers expected"
else do
let (TAC.RailString n1, TAC.RailString n2) = (e2, e1) -- switching might be necessary
res = TAC.RailString $ show $ (read n1 :: Int) `op` (read n2 :: Int)
writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}
searchVar :: String -> [(String, Lexer.IP, Map.Map String TAC.RailType)] -> Maybe TAC.RailType
searchVar _ [] = Nothing
searchVar var ((_, _, vars):xs)
| isNothing $ Map.lookup var vars = searchVar var xs
| otherwise = Map.lookup var vars
getFunctions :: TAC.TextAreaContent -> IO Funcmap
getFunctions tac = do
pGrid <- TAC.getPositionedGrid tac
let (IDT.IPL funcs) = pGrid
let resmap = Map.empty
addnames resmap funcs
where
addnames resmap [] = return resmap
addnames resmap (x:xs) = do
fname <- funcname tac (fst x)
let newmap = Map.insert fname x resmap
addnames newmap xs
getFunctionWith :: TAC.TextAreaContent -> TAC.Position -> IO (String, IDT.Grid2D)
getFunctionWith tac position = do
pGrid <- TAC.getPositionedGrid tac
let (IDT.IPL funcs) = pGrid
funclist = filter isJust $ map (\(f, y) -> if y <= snd position then Just f else Nothing) funcs
if null funclist
then return ("", Map.empty)
else do
let res = fromJust $ last funclist
fname <- funcname tac res
return (fname, res)
funcname :: TAC.TextAreaContent -> IDT.Grid2D -> IO String
funcname tac code = case Lexer.funcname code of
(Left fname) -> return fname
(Right error) -> do
showError tac "No function name"
return ""
needsHalt :: TAC.TextAreaContent -> Funcmap -> IO Bool
needsHalt tac fmap = do
cnt <- readIORef (TAC.context tac)
if null (TAC.funcStack cnt)
then return True
else do
putStrLn "check"
let (fname, ip, _) = head $ TAC.funcStack cnt
let pos = (Lexer.posx ip, Lexer.posy ip + snd (fromJust $ Map.lookup fname fmap))
print (Map.findWithDefault False pos (TAC.breakMap cnt))
return $ Map.findWithDefault False pos (TAC.breakMap cnt)
isNumeric :: TAC.RailType -> Bool
isNumeric (TAC.RailString string) = all (`elem` "0123456789") string
isNumeric _ = False
isList :: TAC.RailType -> Bool
isList (TAC.RailList _) = True
isList _ = False
isNil :: TAC.RailType -> Bool
isNil (TAC.RailList []) = True
isNil _ = False
isString :: TAC.RailType -> Bool
isString (TAC.RailString _) = True
isString _ = False
isBool :: TAC.RailType -> Bool
isBool (TAC.RailString string) = string == "0" || string == "1"
isBool _ = False
isLambda :: TAC.RailType -> Bool
isLambda TAC.RailLambda{} = True
isLambda _ = False
typeOf :: TAC.RailType -> TAC.RailType
typeOf var
| isString var = TAC.RailString "string"
| isNil var = TAC.RailString "nil"
| isList var = TAC.RailString "list"
| isLambda var = TAC.RailString "lambda"