module DSL.Interpretation where

import Data.Foldable (foldlM)

import DSL.Types
import DSL.Util
import DSL.Intrinsics
import DSL.StdLib (stdlib)

newMachine :: Machine
newMachine = Machine { ok=True, stack=[], pTable=[] }

pushData :: Machine -> StackData -> Machine
pushData m@Machine{ stack=xs } x = m{ stack=x:xs }

runModifier :: StackModifier -> Stack -> IO (Either String Stack)
runModifier sm s = case runChecks (smTypes sm) s of
  Just err -> return $ Left $ smName sm ++ ": " ++ err
  Nothing  -> Right <$> smFunc sm s

applyIntrinsic :: Intrinsic -> Machine -> IO Machine
applyIntrinsic i m = do
  res <- runModifier sm (stack m)
  case res of
    Left err -> hcf m err
    Right s' -> return m{ stack=s' }
  where
    sm = case i of
      I_DUMP        -> dump
      I_DROP        -> drop'
      I_SWAP        -> swap
      I_DUP         -> dup
      I_OVER        -> over
      I_ROT         -> rot
      I_PLUS        -> plus
      I_MINUS       -> minus
      I_TIMES       -> times
      I_DIVMOD      -> divMod'
      I_NOT         -> not'
      I_AND         -> and'
      I_OR          -> or'
      I_XOR         -> xor
      I_STRCAT      -> strcat
      I_EQUAL       -> equal
      I_LESSTHAN    -> lessThan
      I_GREATERTHAN -> greaterThan

applyCall :: ProcName -> Machine -> IO Machine
applyCall _ m@Machine{ ok=False } = return m
applyCall name m@Machine{ pTable=t } = case lookup name t of
  Nothing -> hcf m $ "PROCCALL: undefined proc: " ++ name
  Just bs -> evalBlocks bs m

applyOperation :: Machine -> Operation -> IO Machine
-- take no action if a previous step failed
applyOperation m@Machine{ ok=False } _   = return m
applyOperation m (OpPushData x)          = return $ pushData m x
applyOperation m (OpIntrinsic i)         = applyIntrinsic i m
applyOperation m (OpCall name)           = applyCall name m

applyLinear :: Machine -> [Operation] -> IO Machine
applyLinear = foldlM applyOperation

applyIf :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
applyIf _ _ _ m@Machine{ ok=False } = return m
applyIf c t f m                     = do
  m' <- evalBlocks c m
  case m' of
    Machine{ ok=False }                 -> return m'
    Machine{ stack=[] }                 -> hcf m' "IF: stack underflow"
    Machine{ stack=StackBool True:xs }  -> evalBlocks t m'{ stack=xs }
    Machine{ stack=StackBool False:xs } -> evalBlocks f m'{ stack=xs }
    Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"

applyWhile :: [Block] -> [Block] -> Machine -> IO Machine
applyWhile _ _ m@Machine{ ok=False } = return m
applyWhile c b m                     = do
  m' <- evalBlocks c m
  case m' of
    Machine{ ok=False }                 -> return m'
    Machine{ stack=[] }                 -> hcf m' "WHILE: stack underflow"
    Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
    Machine{ stack=StackBool True:xs }  -> do
      m'' <- evalBlocks b m'{ stack=xs }
      applyWhile c b m''
    Machine{ stack=_:_ }                -> hcf m' "WHILE: type mis-match"

evalBlocks :: [Block] -> Machine -> IO Machine
evalBlocks _ m@Machine{ ok=False } = return m
evalBlocks [] m                    = return m
evalBlocks (BLinear b:bs) m        = applyLinear m b >>= evalBlocks bs
evalBlocks (BIf c t f:bs) m        = applyIf c t f m >>= evalBlocks bs
evalBlocks (BWhile c b:bs) m       = applyWhile c b m >>= evalBlocks bs

interpret :: ([ProcSpec], Program) -> IO ()
interpret (t, p) = evalBlocks p newMachine{ pTable=stdlib++t } >> return ()