module Interpreter.Common where import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar 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 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) import qualified SDL as SDL import qualified SDL.Mixer as SDLM import Common import UI.Widgets.Common import Compiler.AST.Program import Compiler.Lexer 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)) 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 | Void deriving Show 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 "Procedures cannot be compared" _ == (ProcedureValue _) = error "Procedures cannot be compared" (BuiltIn _) == _ = error "Procedures cannot be compared" _ == (BuiltIn _) = error "Procedures cannot be compared" Void == _ = error "Void cannot be compared" _ == Void = error "Void 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 deriving Show data DebugIn = AddWatch Text | StepIn | StepOver | Run deriving Show data StepMode = SingleStep | Continue deriving Show data DebugState = DebugState { dsScope :: Scope , dsLocation :: Location , dsCurrenEvaluation :: Maybe Text } deriving Show data DebugOut = Finished | Errored Text | DebugData DebugState deriving Show 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. , isDebugIn :: MVar DebugIn , isDebugOut :: MVar DebugOut , isStepMode :: StepMode , isThreadId :: Maybe ThreadId , isTerminalEventChan :: TChan TerminalEvent } instance Show InterpreterState where show InterpreterState {..} = show (isJust isDefaultWindow) emptyIs :: IORef [SDL.Window] -> MVar DebugIn -> MVar DebugOut -> TChan TerminalEvent -> InterpreterState emptyIs sdlWindowsRef din dout inputChan = InterpreterState mempty DebugMode mempty Nothing Nothing Nothing sdlWindowsRef din dout SingleStep Nothing inputChan 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 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 = "filepath" instance 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 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 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 (V.Vector (Number, Number)) where fromValue (ArrayValue v) = V.map fn v where fn (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1) fn a = throwErr $ UnexpectedType ("list with two values", a) fromValue a = throwErr $ UnexpectedType ("list", a) typeName = "list" 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 : _) = throwErr $ CustomRTE err toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst) 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 | 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 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 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 }