Common.hs

module Interpreter.Common where

import Control.Concurrent
import Control.Concurrent.STM.TBQueue
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TSem
import Control.Exception
import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)
import qualified Data.ByteString as BS
import Data.IORef
import Data.Kind (Type)
import Data.List.NonEmpty
import Data.Map as M
import Data.Maybe (isJust)
import Data.Proxy
import Data.Text as T
import Data.Text.IO as T
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Word
import Foreign.C.Types
import GHC.OverloadedLabels
import GHC.TypeLits
import SDL hiding (Keycode, Scancode, get)
import qualified SDL as SDL
import qualified SDL.Mixer as SDLM
import qualified System.IO as SIO
import Text.Hex (encodeHex)

import Common
import Compiler.AST.Program
import Compiler.Lexer
import DiffRender.DiffRender
import UI.Widgets.Common

audioSampleCount :: Int
audioSampleCount = 44100

type Sample = SDLM.Chunk

data BuiltinVal
  = BuiltinCallWithDoc SomeBuiltin
  | BuiltinCall BuiltInFn
  | BuiltinVal Value

instance Show BuiltinVal where
  show _ = "_builtin_"

newtype SDLKeyboardStateCallback = SDLKeyboardStateCallback (SDL.Scancode -> Bool)

data SDLValue
  = Renderer SDL.Renderer
  | Color (V4 Int)
  | Keycode SDL.Keycode
  | Scancode SDL.Scancode
  | KeyboardState SDLKeyboardStateCallback
  | SoundSample Sample

instance Show SDLValue where
  show (Keycode k)       = "(SDL_KEY)" <> show k
  show (Scancode k)      = "(SDL_SCANCODE)" <> show k
  show (KeyboardState _) = "(SDL_KEYBOARD_STATE)"
  show (Color _)         = "(SDL_COLOR)"
  show (Renderer _)      = "(SDL_RENDERER)"
  show (SoundSample _)   = "(SDL_SOUND)"

data Number
  = NumberInt IntType
  | NumberFractional FloatType
  deriving Show

negateValue :: Number -> Number
negateValue (NumberInt x)        = NumberInt $ negate x
negateValue (NumberFractional x) = NumberFractional $ negate x

numberBinaryFn :: (forall n. Num n => n -> n -> n) -> Number -> Number -> Number
numberBinaryFn fn n1 n2 = case (n1, n2) of
  (NumberInt x, NumberInt y) -> NumberInt $ fn x y
  (NumberFractional x, NumberFractional y) -> NumberFractional $ fn x y
  (NumberInt x, NumberFractional y) -> NumberFractional $ fn (realToFrac x) y
  (NumberFractional x, NumberInt y) -> NumberFractional $ fn x (realToFrac y)

numberBinaryFractionalFn :: (forall n. Fractional n => n -> n -> n) -> Number -> Number -> Number
numberBinaryFractionalFn fn n1 n2 = case (n1, n2) of
  (NumberInt x, NumberInt y) -> NumberFractional $ fn (realToFrac x) (realToFrac y)
  (NumberFractional x, NumberFractional y) -> NumberFractional $ fn x y
  (NumberInt x, NumberFractional y) -> NumberFractional $ fn (realToFrac x) y
  (NumberFractional x, NumberInt y) -> NumberFractional $ fn x (realToFrac y)

instance Eq Number where
  (NumberInt n1) == (NumberInt n2)               = n1 == n2
  (NumberFractional n1) == (NumberFractional n2) = n1 == n2
  (NumberFractional n1) == (NumberInt n2)        = n1 == (realToFrac n2)
  (NumberInt n1) == (NumberFractional n2)        = (realToFrac n1) == n2

instance Ord Number where
  compare (NumberInt x) (NumberInt y)               = compare x y
  compare (NumberFractional x) (NumberFractional y) = compare x y
  compare (NumberInt x) (NumberFractional y)        = compare (realToFrac x) y
  compare (NumberFractional x) (NumberInt y)        = compare x (realToFrac y)

data UnNamedFn = UnNamedFn (Maybe (NonEmpty Identifier)) Scope ExpressionWithLoc
  deriving Show

data ThreadInfo = ThreadInfo ThreadId (TMVar (Either SomeException Value))

instance Show ThreadInfo where
  show _ = "(ThreadInfo)"

newtype ChannelRef = ChannelRef (TChan Value)

instance Show ChannelRef where
  show _ = "(ConcurrencyChannel)"

newtype MutableRef = MutableRef (TMVar Value)

instance Show MutableRef where
  show _ = "(MutableRef)"

data Value
  = StringValue Text
  | NumberValue Number
  | BoolValue Bool
  | BytesValue BS.ByteString
  | ArrayValue (V.Vector Value)
  | ObjectValue (Map Text Value)
  | ProcedureValue FunctionDef
  | UnnamedFnValue UnNamedFn
  | BuiltIn BuiltinVal
  | SDLValue SDLValue
  | ThreadRef ThreadInfo
  | Channel ChannelRef
  | Ref MutableRef
  | ErrorValue Text
      -- ^ This should probably never be used directly, and should throw a CustomRTE instead
      --  so that it will be caught and rethrown with location information.
  | Void
  deriving Show

toStringVal :: Value -> Text
toStringVal = \case
  StringValue t                    -> t
  NumberValue (NumberInt i)        -> pack $ show i
  NumberValue (NumberFractional i) -> pack $ show i
  BoolValue True                   -> "true"
  BoolValue False                  -> "false"
  BytesValue b                     -> "0x" <> encodeHex b
  ArrayValue _                     -> "[array]"
  ObjectValue _                    -> "[object]"
  ProcedureValue _                 -> "(procedure)"
  ThreadRef _                      -> "(thread_ref)"
  Channel _                        -> "(concurrency_channel)"
  Ref _                            -> "(mutable_ref)"
  UnnamedFnValue _                 -> "(unnamed_function)"
  Void                             -> "(void)"
  BuiltIn _                        -> "(builtin)"
  s@(ErrorValue _)                 -> pack $ show s
  SDLValue s                       -> pack $ show s

instance Ord Value where
  compare (NumberValue x) (NumberValue y) = compare x y
  compare _ _                             = error "Cannot be compared"

data ProcResult
  = ProcReturn Bool Value -- Bool indicates tail call
  | ProcBreak
  | ProcContinue

instance Eq Value where
 (StringValue t) == (StringValue v) = t == v
 (NumberValue t) == (NumberValue v)       = t == v
 (BoolValue t) == (BoolValue v)     = t == v
 (BytesValue t) == (BytesValue v)     = t == v
 (ArrayValue t) == (ArrayValue v)   = t == v
 (ObjectValue t) == (ObjectValue v) = t == v
 (SDLValue (Keycode kc1)) == (SDLValue (Keycode kc2)) = kc1 == kc2
 (ProcedureValue _) == _            = error "cannot be compared"
 _ == (ProcedureValue _)            = error "cannot be compared"
 (BuiltIn _) == _                   = error "cannot be compared"
 _ == (BuiltIn _)                   = error "cannot be compared"
 Void == _                          = error "cannot be compared"
 _ == Void                          = error "cannot be compared"
 _ == _                             = False

data ScopeKey
  = SkIdentifier Identifier
  | SkOperator Operator
  deriving (Ord, Eq)

instance Show ScopeKey where
  show (SkIdentifier i) = unpack $ unIdentifer i
  show (SkOperator i)   = show i

type Scope = Map ScopeKey Value

data RunMode
  = NormalMode
  | DebugMode DebugEnv
  deriving Show

data DebugIn
  = StepIn
  | Run
  | Start -- Start stepping through the program
  | StartStep -- Start stepping through the program
  | Stop -- Exit the stepping thread
  deriving (Show, Eq)

data StepMode
  = SingleStep
  | Continue
  deriving Show

data DebugState = DebugState
  { dsScope            :: Scope
  , dsLocation         :: Location
  , dsCurrenEvaluation :: Maybe Text
  , dsThreadName       :: Text
  } deriving (Show, Eq)

data DebugOut
  = Finished Bool
  | Errored Text
  | DebugData DebugState
  deriving (Show, Eq)

data DebugEnv = DebugEnv
  { deStepMode :: StepMode
  , deInQueue  :: TBQueue DebugIn
  , deOutQueue :: TBQueue DebugOut
  }

instance Show DebugEnv where
  show _ = "{DebugEnv}"

data InterpreterState = InterpreterState
  { isLocal           :: [Scope]
  , isRunMode         :: RunMode
  , isGlobalScope     :: Scope
  , isDefaultRenderer :: Maybe SDL.Renderer
  , isAccelerated     :: Maybe Bool
  , isDefaultWindow   :: Maybe SDL.Window
  , isSDLWindows      :: IORef [SDL.Window] -- We need these to cleanup any SDL windows after an exception.
  , isInputHandle     :: SIO.Handle
  , isOutputHandle    :: SIO.Handle
  , isThreadName      :: Text
  , isDiffRender      :: Maybe DiffRender
  , isWidgetState     :: Maybe WidgetState
  , isTerminalParams  :: Maybe (ScreenPos, Dimensions)
  , isStdoutLock      :: Maybe TSem
  , isDefaultPrintParams :: Maybe (Text, Int, [Int])
  -- ^ This lock is required to sync stdout writing when the program
  -- is run from within the IDE and both IDE code and the interepreted
  -- program wants to write to stdout concurrently.
  }

instance Show InterpreterState where
  show InterpreterState {..} = show (isJust isDefaultWindow)

dummyIS :: InterpreterState
dummyIS = InterpreterState
  { isLocal = mempty
  , isRunMode = NormalMode
  , isGlobalScope = mempty
  , isDefaultRenderer = Nothing
  , isAccelerated = Nothing
  , isDefaultWindow = Nothing
  , isSDLWindows = error "Unavailable"
  , isInputHandle = SIO.stdin
  , isOutputHandle = SIO.stdout
  , isThreadName = "MAIN"
  , isDiffRender = Nothing
  , isTerminalParams = Nothing
  , isStdoutLock = Nothing
  , isWidgetState = Nothing
  , isDefaultPrintParams = Nothing
  }

emptyIs :: IORef [SDL.Window] -> InterpreterState
emptyIs sdlWindowsRef = InterpreterState
  { isLocal = mempty
  , isRunMode = NormalMode
  , isGlobalScope = mempty
  , isDefaultRenderer = Nothing
  , isAccelerated = Nothing
  , isDefaultWindow = Nothing
  , isSDLWindows = sdlWindowsRef
  , isInputHandle = SIO.stdin
  , isOutputHandle = SIO.stdout
  , isThreadName = "MAIN"
  , isDiffRender = Nothing
  , isTerminalParams = Nothing
  , isStdoutLock = Nothing
  , isWidgetState = Nothing
  , isDefaultPrintParams = Just (".", 2, [3, 2, 2, 2, 2, 2, 2])
  }

interpreterOutput :: Text -> InterpretM ()
interpreterOutput c = isOutputHandle <$> get >>= (liftIO . flip T.hPutStr c)

interpreterOutputFlush :: InterpretM ()
interpreterOutputFlush = isOutputHandle <$> get >>= (liftIO . SIO.hFlush)

interpreterInputChar :: InterpretM Char
interpreterInputChar = isInputHandle <$> get >>= (liftIO . SIO.hGetChar)

interpreterInput :: InterpretM Text
interpreterInput = isInputHandle <$> get >>= (liftIO . T.hGetContents)

readInterpreterInputLine :: InterpretM Text
readInterpreterInputLine = readInput ""
  where
    readInput ti = do
      c <- interpreterInputChar
      case c of
        '\n' -> pure $ T.reverse $ T.pack ti
        '\ESC' -> do
            interpreterOutput "\nInput cancelled, please try again: "
            interpreterOutputFlush
            readInput ""
        '\BS' -> readInput ti
        _ -> do
          interpreterOutput (T.singleton c)
          interpreterOutputFlush
          readInput (c:ti)

mapLocal :: ([Scope] -> [Scope]) -> (InterpreterState -> InterpreterState)
mapLocal fn = \is -> is { isLocal = fn $ isLocal is }

mapGlobalScope :: (Scope -> Scope) -> (InterpreterState -> InterpreterState)
mapGlobalScope fn = \is -> is { isGlobalScope = fn $ isGlobalScope is }

type InterpretM a = forall m. (MonadCatch m, MonadIO m) => StateT InterpreterState m a

runInterpretM :: (MonadCatch m, MonadIO m) => InterpreterState -> InterpretM a -> m (a, InterpreterState)
runInterpretM istate act  = flip runStateT (istate) act

instance {-# OVERLAPPING #-} (MonadCatch m, MonadIO m) => MonadIO (StateT InterpreterState m) where
  liftIO act = lift $ liftIO @m (wrapSomeException IOError act)

type BuiltInFnWithDoc s = NamedArgs s -> InterpretM (Maybe Value)
type BuiltInFn = [Value] -> InterpretM (Maybe Value)

data Callback
  = CallbackUnNamed UnNamedFn
  | CallbackNamed Identifier

instance FromValue (M.Map Text Value) where
  fromValue (ObjectValue t) = t
  fromValue a               = throwErr $ UnexpectedType ("object", a)
  typeName = "object"

instance FromValue ThreadInfo where
  fromValue (ThreadRef t) = t
  fromValue a             = throwErr $ UnexpectedType ("thread_ref", a)
  typeName = "thread_ref"

instance FromValue ChannelRef where
  fromValue (Channel t) = t
  fromValue a           = throwErr $ UnexpectedType ("concurrency_channel", a)
  typeName = "concurrency_channel"

instance FromValue MutableRef where
  fromValue (Ref t) = t
  fromValue a       = throwErr $ UnexpectedType ("mutable_reference", a)
  typeName = "mutable_reference"

instance FromValue BytesOrText where
  fromValue (StringValue t) = BTText t
  fromValue (BytesValue t)  = BTBytes t
  fromValue a               = throwErr $ UnexpectedType ("filepath", a)
  typeName = "bytes_or_text"

instance FromValue TextOrList where
  fromValue (StringValue t) = TCText t
  fromValue (ArrayValue t)  = TCList t
  fromValue a               = throwErr $ UnexpectedType ("text_or_list", a)
  typeName = "text_or_list"

instance {-# OVERLAPPING #-} FromValue FilePath where
  fromValue (StringValue t) = T.unpack t
  fromValue a               = throwErr $ UnexpectedType ("filepath", a)
  typeName = "filepath"

instance FromValue Sample where
  fromValue (SDLValue (SoundSample s)) = s
  fromValue a = throwErr $ UnexpectedType ("soundsample", a)
  typeName = "soundsample"

instance FromValue Text where
  fromValue (StringValue t) = t
  fromValue a               = throwErr $ UnexpectedType ("string", a)
  typeName = "string"

instance FromValue BS.ByteString where
  fromValue (BytesValue b) = b
  fromValue a              = throwErr $ UnexpectedType ("bytes", a)
  typeName = "bytes"

instance FromValue SDL.Scancode where
  fromValue (SDLValue (Scancode sc)) = sc
  fromValue a                        = throwErr $ UnexpectedType ("scancode", a)
  typeName = "scancode"

instance FromValue SDLKeyboardStateCallback where
  fromValue (SDLValue (KeyboardState cb)) = cb
  fromValue a = throwErr $ UnexpectedType ("callback", a)
  typeName = "keyboardstate"

instance FromValue Callback where
  fromValue (UnnamedFnValue un) = CallbackUnNamed un
  fromValue (ProcedureValue (FunctionDef idf _ _)) = CallbackNamed idf
  fromValue a = throwErr $ UnexpectedType ("callback", a)
  typeName = "callback"

class FromValue a where
  fromValue :: Value -> a
  fromError :: Text -> a
  fromError err = throwErr $ CustomRTE err
  typeName :: Text

instance FromValue SDL.Keycode where
  fromValue (SDLValue (Keycode keycode)) = keycode
  fromValue a = throwErr $ UnexpectedType ("keycode", a)
  typeName = "keycode"

instance FromValue Int where
  fromValue (NumberValue (NumberInt i)) = fromIntegral i
  fromValue (NumberValue (NumberFractional i)) = round i
  fromValue a            = throwErr $ UnexpectedType ("number", a)
  typeName = "integer"

instance FromValue SDLM.Channel where
  fromValue = fromIntegral . fromValue @Int
  typeName = "channel"

instance FromValue Bool where
  fromValue (BoolValue b) = b
  fromValue a             = throwErr $ UnexpectedType ("boolean", a)
  typeName = "boolean"

instance FromValue Integer where
  fromValue (NumberValue (NumberInt i)) = i
  fromValue (NumberValue (NumberFractional i)) = round i
  fromValue a            = throwErr $ UnexpectedType ("number", a)
  typeName = "integer"

instance FromValue Double where
  fromValue (NumberValue (NumberInt i)) = realToFrac i
  fromValue (NumberValue (NumberFractional i)) = i
  fromValue a            = throwErr $ UnexpectedType ("fractional", a)
  typeName = "fractional"

instance FromValue a => FromValue (V.Vector a) where
  fromValue (ArrayValue v) = V.map fromValue v
  fromValue a              = throwErr $ UnexpectedType ("number", a)
  typeName = "list of " <> (typeName @a)

instance FromValue a => FromValue [a] where
  fromValue (ArrayValue v) = V.toList $ V.map fromValue v
  fromValue a              = throwErr $ UnexpectedType ("number", a)
  typeName = "list of " <> (typeName @a)

instance FromValue Number where
  fromValue (NumberValue i) = i
  fromValue a               = throwErr $ UnexpectedType ("number", a)
  typeName = "number"

instance FromValue CInt where
  fromValue (NumberValue (NumberInt i)) = fromIntegral i
  fromValue (NumberValue (NumberFractional i)) = fromIntegral $ round i
  fromValue a            = throwErr $ UnexpectedType ("number", a)
  typeName = "number"

instance FromValue Value where
  fromValue = id
  typeName = "any"

mkPoint :: CInt -> CInt -> SDL.Point SDL.V2 CInt
mkPoint x y = SDL.P (SDL.V2 x y)

instance FromValue (VS.Vector (SDL.Point V2 CInt)) where
  fromValue (ArrayValue v) = VS.fromList $ V.toList $ fn <$> v
    where
      fn :: Value -> SDL.Point V2 CInt
      fn (ArrayValue (V.toList -> [v1, v2])) = mkPoint (fromValue v1) (fromValue v2)
      fn a = throwErr $ UnexpectedType ("list(2)", a)
  fromValue a = throwErr $ UnexpectedType ("list", a)
  typeName = "list"

instance FromValue (Number, Number) where
  typeName = "tuple"
  fromValue (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1)
  fromValue a = throwErr $ UnexpectedType ("list with two values", a)

instance FromValue Word8 where
  fromValue = \case
    (NumberValue (NumberInt i)) -> fromInt i
    (NumberValue (NumberFractional i)) -> fromInt (round i)
    a -> throwErr $ UnexpectedType ("number", a)
    where
      fromInt i = if (fromIntegral i) <= (maxBound @Word8) then fromIntegral i else throwErr $ CustomRTE "Number too large to be converted to a byte"
  typeName = "number"

newtype Variadic = Variadic [Value]

instance FromValue Variadic where
  fromValue v = Variadic [v]
  typeName = "variadic argument"

newtype NamedArg (s :: Symbol) a = NamedArg a

instance KnownSymbol s => IsLabel s (a -> NamedArg s a) where
  fromLabel = NamedArg

data NamedArgs (s :: [(Symbol, Type)]) where
  EmptyArgs :: NamedArgs '[]
  (:>) :: (KnownSymbol s, FromValue a) => NamedArg s a -> NamedArgs r -> NamedArgs ('(s, a) ': r)
infixr 8 :>

class KnownArgs a where
  toArgDoc :: [(Text, Text)]
  toArgs :: [Value] -> NamedArgs a

instance {-# OVERLAPPING #-} KnownSymbol n => KnownArgs '[ '(n, Variadic)] where
  toArgDoc = [("variadic", "Value")]
  toArgs x = NamedArg (Variadic x) :> EmptyArgs

instance KnownArgs '[] where
  toArgDoc = []
  toArgs [] = EmptyArgs
  toArgs _  = error "Unexpected arguments"

instance (KnownSymbol n, FromValue t, KnownArgs s) => KnownArgs (('(n, t) ': s)) where
  toArgDoc = (pack $ symbolVal (Proxy @n), typeName @t) : toArgDoc @s
  toArgs []        = throwErr  $ BadArguments ((pack $ symbolVal (Proxy @n)) <> " of type " <> typeName @t, "No argument")
  toArgs (ErrorValue err : rst) = (NamedArg $ fromError @t err) :> (toArgs @s rst)  -- throwErr $ CustomRTE err
  toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst)

data EitherError a = EitherError (Either Text a)

instance FromValue a => FromValue (EitherError a) where
  fromValue v = EitherError (Right $ fromValue v)
  fromError err = EitherError (Left err)
  typeName = (typeName @a) <> "(optional)"

instance FromValue a => FromValue (Maybe a) where
  fromValue v = Just $ fromValue v
  typeName = (typeName @a) <> "(optional)"

instance {-# OVERLAPPING #-} (KnownSymbol n, FromValue t, KnownArgs s) => KnownArgs (('(n, Maybe t) ': s)) where
  toArgDoc = (pack $ symbolVal (Proxy @n), typeName @(Maybe t)) : toArgDoc @s
  toArgs []        = (NamedArg (Nothing :: Maybe t)) :> (toArgs @s [])
  toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst)

data SomeBuiltin where
  SomeBuiltin :: KnownArgs s => (NamedArgs s -> InterpretM (Maybe Value)) -> SomeBuiltin

extractDoc :: SomeBuiltin -> [(Text, Text)]
extractDoc (SomeBuiltin (_ :: NamedArgs s -> InterpretM (Maybe Value))) = toArgDoc @s

wrapSomeException :: (Text -> RuntimeError) -> IO a -> IO a
wrapSomeException fn act =
  flip catch (\(e :: SomeException) -> case fromException @AsyncException e of
    Just _ -> throwM e
    _ -> case fromException @IOException e of
      Just _  -> throwM $ fn $ T.pack $ displayException e
      Nothing -> throwM e) act

instance HReadable (Either RuntimeError ProgramError) where
  hReadable (Right x) = hReadable x
  hReadable (Left x)  = hReadable x

data RuntimeErrorWithLoc =  RuntimeErrorWithLoc (Either RuntimeError ProgramError) Location

instance HReadable RuntimeErrorWithLoc where
  hReadable (RuntimeErrorWithLoc msg loc) = "Runtime error: " <> (hReadable msg) <> ", at: " <> (hReadable loc)

instance Show RuntimeErrorWithLoc where
  show = T.unpack . hReadable

instance Exception RuntimeErrorWithLoc where

data ProgramError
  = SymbolNotFound Text
  | UnexpectedType (Text, Value)
  | MissingProcedureReturn
  | EmptyScopeStack
  | BadArguments (Text, Text)

data RuntimeError
  = IOError Text
  | SDLError Text
  | ListIndexOutOfBounds Int
  | KeyNotFound Text
  | UnserializeableValue
  | CustomRTE Text

instance Show RuntimeError where
  show = T.unpack . hReadable

instance Show ProgramError where
  show = T.unpack . hReadable

instance HReadable ProgramError where
  hReadable = \case
    SymbolNotFound s -> "Unknown symbol reference: '" <> s <>"'"
    UnexpectedType (e, f) -> case f of
      ErrorValue t -> t
      _ -> "Unexpected type, expected " <> e <> ", but got: " <> (T.pack $ show f)
    MissingProcedureReturn -> "Function or callback call did not return a value as expected"
    EmptyScopeStack -> "Stack was unexpectedly empty"
    BadArguments (e, f) -> "Unexpected argument count or type, expected: " <> e <> ", but got: " <> f

instance HReadable RuntimeError where
  hReadable = \case
    IOError t -> "Input/Output error: " <> t
    SDLError t -> "SDL error: " <> t
    ListIndexOutOfBounds t -> "Out of bound access of a list at index: " <> (T.pack $ show t)
    KeyNotFound t -> "Non-existing key access in dictionary at key: " <> t
    CustomRTE t -> "Run time error: " <> t
    UnserializeableValue -> "UnserializeableValue"

throwBadArgs :: [Value] -> Text -> InterpretM (Maybe Value)
throwBadArgs v' m = throwBadArgs' v' [] m
  where
    throwBadArgs' :: [Value] -> [Value] -> Text -> InterpretM (Maybe Value)
    throwBadArgs' (v@(ErrorValue _): _) _ _ = pure $ Just v
    throwBadArgs' (v : rst) bargs msg  = throwBadArgs' rst (v:bargs) msg
    throwBadArgs' [] bargs msg = throwErr $ BadArguments (msg, T.pack $ show $ Prelude.reverse bargs)

data BytesOrText
  = BTBytes BS.ByteString
  | BTText Text
  deriving Show

data TextOrList
  = TCList (V.Vector Value)
  | TCText Text
  deriving Show

instance Exception RuntimeError where
  displayException e = T.unpack $ hReadable e

instance Exception ProgramError where
  displayException e = T.unpack $ hReadable e

class InterpreterException a where
  throwErr :: (Exception e) => e -> a

instance InterpreterException a where
  throwErr r = throw r

instance {-# OVERLAPPING #-} InterpreterException ([] a) where
  throwErr r = throw r

instance {-# OVERLAPPING #-} MonadThrow m => InterpreterException (StateT InterpreterState m a) where
  throwErr = throwM

waitMillisec' :: Number -> IO ()
waitMillisec' number = case number of
  NumberFractional v -> do
    threadDelay (round $ v * 1000000)
  NumberInt v -> do
    threadDelay (fromInteger $ v * 1000000)

insertBuiltInVal :: ScopeKey -> Value -> InterpretM ()
insertBuiltInVal sk val = modify $ mapGlobalScope fn
  where
    fn :: Scope -> Scope
    fn s = M.insert sk (BuiltIn $ BuiltinVal val) s

insertBuiltIn :: ScopeKey -> BuiltInFn -> InterpretM ()
insertBuiltIn sk val = modify $ mapGlobalScope fn
  where
    fn :: Scope -> Scope
    fn s = M.insert sk (BuiltIn $ BuiltinCall val) s

insertBuiltInWithDoc :: ScopeKey -> SomeBuiltin -> InterpretM ()
insertBuiltInWithDoc sk val = modify $ mapGlobalScope fn
  where
    fn :: Scope -> Scope
    fn s = M.insert sk (BuiltIn $ BuiltinCallWithDoc val) s

insertBinding :: ScopeKey -> Value -> InterpretM ()
insertBinding sk val = modify fn
  where
    fn :: InterpreterState -> InterpreterState
    fn is@(InterpreterState { isGlobalScope, isLocal }) = case isLocal of
      []        -> is { isGlobalScope = M.insert sk val isGlobalScope }
      (s : rst) -> is { isLocal = (M.insert sk val s) : rst }

-- | Separates the given text using the decimal separator
-- and inserts commas as specivied by the positions list
-- into the non-fractional part.
amountFormat :: Text -> [Int] -> Text -> Text
amountFormat sep pos v = let
  (n, f) = T.breakOn sep v
  in (putCommas pos n) <> f
  where
    putCommas :: [Int] -> Text -> Text
    putCommas pos' v' = T.reverse $ T.intercalate "," (splitPos pos' (T.reverse v'))

    splitPos :: [Int] -> Text -> [Text]
    splitPos [] "" = []
    splitPos [] v' = [v']
    splitPos _ "" = []
    splitPos (p: rs) v' = (T.take p v') : (splitPos rs (T.drop p v'))