Common.hs

module Interpreter.Common where

import Control.DeepSeq
import Control.Concurrent
import Control.Monad.IO.Unlift
import Control.Concurrent.STM.TBQueue
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TSem
import Control.Concurrent.STM.TVar
import Control.Monad.State.Strict
import Control.Concurrent.STM (atomically)
import Control.Monad.Reader
import Control.Exception
import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)
import Crypto.Hash
import GHC.Generics
import qualified Data.ByteString as BS
import Data.IORef
import Data.Kind (Type)
import Data.Map as M
import Data.Maybe (fromMaybe, 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.Int (Int16)
import GHC.TypeLits
import SDL hiding (Keycode, Scancode, get)
import qualified SDL as SDL
import qualified SDL.Mixer as SDLM
import qualified SDL.Font as SDLF
import System.IO
import qualified System.IO as SIO
import System.Posix.Directory
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
  deriving Generic

instance NFData BuiltinVal

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
  | Texture SDL.Texture
  | Font SDLF.Font

instance NFData SDLValue where
  rnf _ = ()

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)"
  show (Texture _)       = "(SDL_TEXTURE)"
  show (Font _)          = "(SDL_FONT)"

data Number
  = NumberInt IntType
  | NumberFractional FloatType
  deriving (Generic, Show)

instance NFData Number

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 [Identifier] Scope ExpressionWithLoc
  deriving (Show, Generic)

instance NFData UnNamedFn

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

instance NFData ThreadInfo where
  rnf _ = ()

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

newtype ChannelRef = ChannelRef (TChan Value)

instance NFData ChannelRef where
  rnf _ = ()

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

data MutableRef = MutableRef { mref :: (TMVar Value), mrsem :: TSem }

instance NFData MutableRef where
  rnf _ = ()

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

newtype AbsoluteFilePath = AbsoluteFilePath FilePath deriving Show

data DirStreamInfo = DirStreamInfo AbsoluteFilePath (Maybe DirStream)

instance Show DirStreamInfo where
  show (DirStreamInfo afp (Just _)) = show (afp, "Just _")
  show (DirStreamInfo afp _)        = show (afp, "Nothing")

data DirHandleRef = DirHandleRef Bool (TVar [DirStreamInfo])

instance NFData DirHandleRef where
  rnf _ = ()

instance Show DirHandleRef where
  show _ = "(Directory)"

data HashContext =
  MD5HashContext (Context MD5)

instance NFData HashContext where
  rnf _ = ()

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

data FileHandle =
  FileHandle Handle

instance NFData FileHandle where
  rnf _ = ()

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

newtype ScopeRef = ScopeRef (TVar Scope)

instance NFData ScopeRef where
  rnf _ = ()

instance Show ScopeRef where
  show _ = "(scoperef)"

data GeneratorChannels = GeneratorChannels (TChan ()) (TChan (Maybe Value))

instance NFData GeneratorChannels where
  rnf _ = ()

instance Show GeneratorChannels where
  show _ = "(generator)"

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
  | DirectoryStack DirHandleRef
  | FileHandleValue FileHandle
  | WidgetValue SomeWidgetRef
  | HashContextValue HashContext
  | EventValue KeyEvent
  | GeneratorValue GeneratorChannels
  | ModuleValue FilePath ScopeRef (Maybe Identifier)
  | 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 (Generic, Show)

instance NFData Value

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)"
  GeneratorValue _                 -> "(generator)"
  Void                             -> "(void)"
  BuiltIn _                        -> "(builtin)"
  DirectoryStack _                 -> "(directory)"
  WidgetValue _                    -> "(widget)"
  HashContextValue _               -> "(hash_context)"
  FileHandleValue _                -> "(file_handle)"
  ModuleValue _ _ _                  -> "(module)"
  s@(ErrorValue _)                 -> pack $ show s
  SDLValue s                       -> pack $ show s
  EventValue ke                    -> pack $ show ke

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, Generic)

instance NFData ScopeKey

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 LogMode
  = SyncAutoRefresh (TBQueue Text)
  | AsyncDeferedRefresh (TBQueue Text)
  | NoLog

data InterpreterState = InterpreterState
  { isLocal              :: [Scope]
  , isCurrentModulePath  :: Maybe FilePath
  , isRunMode            :: RunMode
  , isGeneratorChannels  :: Maybe GeneratorChannels
  , isGlobalScope        :: Scope
  , isModuleScope        :: [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
  , isLogChannel         :: LogMode
  , isDefaultPrintParams :: Maybe (Text, Int, [Int])
  , isDefaultFont        :: Maybe SDLF.Font
  , isBgColor            :: Maybe (Word8, Word8, Word8, Word8)
  -- ^ 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 HasDiffRender (ReaderT (TVar InterpreterState) IO) where
  getDiffRender = (fromMaybe (error "Char screen not initialized") . isDiffRender) <$> getInterpretM
  putDiffRender dfr = modifyInterpretM (\us -> us { isDiffRender = Just dfr })
  modifyDiffRender fn = modifyInterpretM (\us -> us { isDiffRender = fn <$> (isDiffRender us) })

instance HasWidgetState (ReaderT (TVar InterpreterState) IO) where
  getWidgetState = (fromMaybe (error "Widgets not initialized") . isWidgetState) <$> getInterpretM
  getWidgetStateMaybe = isWidgetState <$> getInterpretM
  putWidgetState ws = modifyInterpretM (\us -> us { isWidgetState = Just ws })
  modifyWidgetState fn = modifyInterpretM (\us -> us { isWidgetState = fn <$> isWidgetState us })

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

dummyIS :: InterpreterState
dummyIS = InterpreterState
  { isLocal = mempty
  , isRunMode = NormalMode
  , isGeneratorChannels = Nothing
  , isCurrentModulePath = Nothing
  , isGlobalScope = mempty
  , isModuleScope = mempty
  , isDefaultRenderer = Nothing
  , isAccelerated = Nothing
  , isDefaultWindow = Nothing
  , isSDLWindows = error "Unavailable"
  , isInputHandle = SIO.stdin
  , isOutputHandle = SIO.stdout
  , isThreadName = "MAIN"
  , isDiffRender = Nothing
  , isTerminalParams = Nothing
  , isStdoutLock = Nothing
  , isLogChannel = NoLog
  , isWidgetState = Nothing
  , isDefaultPrintParams = Nothing
  , isDefaultFont = Nothing
  , isBgColor = Nothing
  -- ^ Some parameters that decides the comma placement when numbers are printed.
  }

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

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

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

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

interpreterInput :: InterpretM Text
interpreterInput = isInputHandle <$> getInterpretM >>= (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 = ReaderT (TVar InterpreterState) IO a

withStateClone :: InterpretM a -> InterpretM a
withStateClone act = do
  sVar <- ask
  svarClone <- liftIO $ atomically $ do
    currentVal <- readTVar sVar
    newTVar currentVal
  local (const svarClone) act

getInterpretM :: InterpretM InterpreterState
getInterpretM = do
  stateTvar <- ask
  liftIO $ readTVarIO stateTvar

setInterpretM :: InterpreterState -> InterpretM ()
setInterpretM newstate = do
  stateTvar <- ask
  liftIO $ atomically $ writeTVar stateTvar newstate

modifyInterpretM :: (InterpreterState -> InterpreterState) -> InterpretM ()
modifyInterpretM modFn = do
  stateTvar <- ask
  liftIO $ atomically $ modifyTVar' stateTvar modFn

runInterpretM ::  InterpreterState -> InterpretM a -> IO (a, InterpreterState)
runInterpretM istate act  = do
  stvar <- liftIO $ newTVarIO istate
  r <- flip runReaderT stvar act
  s <- readTVarIO stvar
  pure (r, s)

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 SomeWidgetRef where
  fromValue (WidgetValue s) = s
  fromValue a               = throwErr $ UnexpectedType ("widget", a)
  typeName = "widget"

instance FromValue GeneratorChannels where
  fromValue (GeneratorValue s) = s
  fromValue a               = throwErr $ UnexpectedType ("generator", a)
  typeName = "generator"

instance FromValue KeyEvent where
  fromValue (EventValue s) = s
  fromValue a              = throwErr $ UnexpectedType ("event", a)
  typeName = "event"

instance FromValue Handle where
  fromValue (FileHandleValue (FileHandle t)) = t
  fromValue a               = throwErr $ UnexpectedType ("file_handle", a)
  typeName = "file_handle"

instance FromValue HashContext where
  fromValue (HashContextValue t) = t
  fromValue a                    = throwErr $ UnexpectedType ("hash_context", a)
  typeName = "hash_context"

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 SDL.Texture where
  fromValue (SDLValue (Texture s)) = s
  fromValue a = throwErr $ UnexpectedType ("texture", a)
  typeName = "texture"

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 CDouble where
  fromValue (NumberValue (NumberInt i)) = realToFrac i
  fromValue (NumberValue (NumberFractional i)) = realToFrac i
  fromValue a            = throwErr $ UnexpectedType ("fractional", a)
  typeName = "fractional"

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 Int16 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 :: a -> a -> SDL.Point SDL.V2 a
mkPoint x y = SDL.P (SDL.V2 x y)

instance forall a. (FromValue a, VS.Storable a) => FromValue (VS.Vector (SDL.Point V2 a)) where
  fromValue (ArrayValue v) = VS.fromList $ V.toList $ fn <$> v
    where
      fn :: Value -> SDL.Point V2 a
      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 a, FromValue b) => FromValue (a, b) where
  typeName = "tuple"
  fromValue (ArrayValue (V.toList -> ((fromValue -> idx0) : (fromValue -> idx1) : _))) = (idx0, idx1)
  fromValue a = throwErr $ UnexpectedType ("list with two values", a)

instance FromValue Char where
  typeName = "char"
  fromValue = \case
    StringValue x -> if T.length x == 1 then T.head x else throwErr $ CustomRTE "A string of length one char expected, but got many or none"
    a -> throwErr $ UnexpectedType ("string", a)

instance FromValue Word8 where
  fromValue = \case
    (NumberValue (NumberInt i)) -> fromInt i
    (NumberValue (NumberFractional i)) -> fromInt (round i)
    (BytesValue b) -> if BS.length b == 1 then BS.head b else throwErr $ CustomRTE "One byte expected, but got many or none"
    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

instance NFData SomeBuiltin where
  rnf _ = ()

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
  | EmptyModuleScopeStack
  | BadArguments (Text, Text)

data RuntimeError
  = IOError Text
  | SDLError Text
  | IndexOutOfBounds Int
  | GeneratorExhausted
  | 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"
    EmptyModuleScopeStack -> "Module 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
    GeneratorExhausted -> "A generator has run out"
    SDLError t -> "SDL error: " <> t
    Interpreter.Common.IndexOutOfBounds t -> "Out of bound access of 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 = modifyInterpretM $ mapGlobalScope fn
  where
    fn :: Scope -> Scope
    fn s = M.insert sk (BuiltIn $ BuiltinVal val) s

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

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

insertBinding :: Bool -> ScopeKey -> Value -> InterpretM ()
insertBinding isGlobal sk val = modifyInterpretM fn
  where
    fn :: InterpreterState -> InterpreterState
    fn is@(InterpreterState { isModuleScope, isLocal }) = case (isLocal, isModuleScope, isGlobal) of
      ([], (ms: rst),  _)        -> is { isModuleScope = (M.insert sk val ms) : rst }
      (_, (ms: rst), True)        -> is { isModuleScope = (M.insert sk val ms) : rst }
      ((s : rst), _, False) -> is { isLocal = (M.insert sk val s) : rst }
      a -> error $ show a

-- | 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'))