Misc.hs

module Interpreter.Lib.Misc where

import Control.Monad.IO.Class
import Control.Concurrent.STM
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import Data.Text.Encoding
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce
import qualified Data.Scientific as S
import Data.Map as M
import Text.Hex (encodeHex)
import Data.HashMap.Strict as HM
import Data.Text as T
import Data.Text.IO as T
import Data.Time.Clock.System
import Data.Vector as V
import qualified System.IO as S
import Control.Monad.State.Strict as SM

import UI.Widgets.Common
import Interpreter.Common

printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)]
printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do
  liftIO $ do
    UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals)
    T.putStrLn ""
    S.hFlush S.stdout
  pure Nothing

printVal :: BuiltInFnWithDoc '[ '("value", Variadic)]
printVal ((coerce -> (Variadic vals)) :> EmptyArgs) = do
  liftIO $ do
    UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals)
    S.hFlush S.stdout
  pure Nothing

multiplication :: BuiltInFn
multiplication (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (*) v1 v2
multiplication a = throwBadArgs a "number"

addition :: BuiltInFn
addition (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (+) v1 v2
addition (ArrayValue i1 : ArrayValue i2 : []) = pure $ Just $ ArrayValue $ i1 V.++ i2
addition a = throwBadArgs a "number/list"

substraction :: BuiltInFn
substraction (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (-) v1 v2
substraction a = throwBadArgs a "number"

division :: BuiltInFn
division (NumberValue _: NumberValue (NumberInt 0) : []) = throwErr $ CustomRTE "Divison by zero!"
division (NumberValue _: NumberValue (NumberFractional 0.0) : []) = throwErr $ CustomRTE "Divison by zero!"
division (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFractionalFn (/) v1 v2
division a = throwBadArgs a "number"

comparison :: (Value -> Value -> Bool) -> BuiltInFn
comparison fn (v1: v2 : []) = pure $ Just $ BoolValue (fn v1 v2)
comparison _ a              = throwBadArgs a "values"

boolean :: (Bool -> Bool -> Bool) -> BuiltInFn
boolean fn (BoolValue v1 : BoolValue v2 : []) = pure $ Just $ BoolValue (fn v1 v2)
boolean _ a              = throwBadArgs a "bools"

not' :: BuiltInFnWithDoc '[ '("bool", Bool)]
not' ((coerce -> v1) :> _) = pure $ Just $ BoolValue (not v1)

contains :: BuiltInFnWithDoc '[ '("list", Vector Value), '("item", Value)]
contains ((coerce -> v1) :> (coerce -> v2) :> _) = pure $ Just $ BoolValue $ V.foldl' fn False v1
  where
    fn :: Bool -> Value -> Bool
    fn True _  = True
    fn False v = v2 == v

haskey :: BuiltInFnWithDoc '[ '("dictionary",  M.Map Text Value), '("key", Text)]
haskey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> _) = pure $ Just $ BoolValue $ M.member key map'

arrayTake :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]
arrayTake ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.take c v1)

arrayDrop :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]
arrayDrop ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.drop c v1)

builtInArrayInsertLeft :: BuiltInFnWithDoc ['("item", Value), '("initial_list", Vector Value)]
builtInArrayInsertLeft ((coerce -> c) :> (coerce -> v1) :> _) = pure $ Just $ ArrayValue (V.cons c v1)

builtInArrayInsertRight :: BuiltInFnWithDoc ['("initial_list", Vector Value), '("item", Value)]
builtInArrayInsertRight ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.snoc v1 c)

builtInWriteFile :: BuiltInFnWithDoc '[ '("filename", FilePath), '("data", BytesOrText)]
builtInWriteFile ((coerce -> filepath) :> (coerce -> bot) :> EmptyArgs) = liftIO $ case bot of
  BTBytes bin -> do
      BS.writeFile filepath bin
      pure Nothing
  BTText dat -> do
      T.writeFile filepath dat
      pure Nothing

builtInReadFile :: BuiltInFnWithDoc '[ '("filename", FilePath)]
builtInReadFile ((coerce -> filepath) :> _) = liftIO $ do
  c <- BS.readFile filepath
  pure $ Just $ BytesValue c

builtInReadTextFile :: BuiltInFnWithDoc '[ '("filename", FilePath)]
builtInReadTextFile ((coerce -> filepath) :> _) = do
  c <- liftIO $ T.readFile filepath
  pure $ Just $ StringValue c

builtInHead :: BuiltInFnWithDoc '[ '("source_list", Vector Value)]
builtInHead ((coerce -> v1) :> _) = case V.uncons v1 of
  Just (x, _) -> pure $ Just x
  Nothing     -> throwErr $ CustomRTE "Empty list found for 'head' call"

builtInTry :: BuiltInFnWithDoc '[ '("evaluation", Value), '("alternate", Maybe Value)]
builtInTry ((coerce -> evaluation) :>  (coerce -> malternate) :> _) = case (evaluation, malternate) of
  (ErrorValue _, Just a)      -> pure $ Just a
  (e@(ErrorValue _), Nothing) -> pure $ Just e
  (v, _)                      -> pure $ Just v

builtInTimestamp :: BuiltInFnWithDoc '[]
builtInTimestamp _ = do
  st <- liftIO $ truncateSystemTimeLeapSecond <$> getSystemTime
  pure $ Just $ NumberValue $ NumberInt $ ((fromIntegral $ systemSeconds st) * 1e9) + (fromIntegral $ systemNanoseconds st)

builtInJSONSerialize :: BuiltInFnWithDoc '[ '("value", Value)]
builtInJSONSerialize ((coerce -> (v :: Value)) :> _) =
  (Just . BytesValue . BSL.toStrict . A.encode) <$> toAesonVal v

builtInInspect :: BuiltInFnWithDoc '[ '("value", Value)]
builtInInspect ((coerce -> (v :: Value)) :> _) = do
  vText <- (decodeUtf8 . BSL.toStrict . A.encode) <$> toAesonVal v
  liftIO $ do
    T.putStr vText
    S.hFlush S.stdout
  pure Nothing

builtInJSONParse :: BuiltInFnWithDoc '[ '("value", Value)]
builtInJSONParse v  = let
  bytes = case v of
    ((coerce -> (StringValue b)) :> _) -> encodeUtf8 b
    ((coerce -> (BytesValue b)) :> _) -> b
    ((coerce -> (a :: Value)) :> _) -> throwErr $ BadArguments ("String/Bytes", T.pack $ show a)
  in case A.eitherDecodeStrict bytes of
    Right val -> pure $ Just $ fromAesonVal val
    Left err -> pure $ Just $ ErrorValue ("JSON decoding failed with error:" <> (T.pack err))

builtInDecodeUTF8Bytes :: BuiltInFnWithDoc '[ '("bytes", BS.ByteString)]
builtInDecodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ StringValue $ decodeUtf8 b

builtInEncodeUTF8Bytes :: BuiltInFnWithDoc '[ '("string", Text)]
builtInEncodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ BytesValue $ encodeUtf8 b

builtInDebug :: BuiltInFnWithDoc '[]
builtInDebug _ = do
  SM.modify (\is -> is { isRunMode = DebugMode, isStepMode = SingleStep })
  pure Nothing

fromAesonVal :: A.Value -> Value
fromAesonVal (A.String s) = StringValue s
fromAesonVal (A.Number s) = NumberValue $ if S.isInteger s then NumberInt (round s) else NumberFractional (realToFrac s)
fromAesonVal (A.Bool b) = BoolValue b
fromAesonVal (A.Array b) = ArrayValue (fromAesonVal <$> b)
fromAesonVal (A.Object b) = ObjectValue (M.fromList $ HM.toList $ fromAesonVal <$> b)
fromAesonVal A.Null = Void

toAesonVal :: Value -> InterpretM A.Value
toAesonVal Void = pure A.Null
toAesonVal (StringValue s) = pure $ A.String s
toAesonVal (NumberValue (NumberInt n)) = pure $ A.Number $ fromIntegral n
toAesonVal (NumberValue (NumberFractional n)) = pure $ A.Number $ realToFrac n
toAesonVal (BoolValue b) = pure $ A.Bool b
toAesonVal (ArrayValue b) = do
  vs <- V.mapM (\x -> toAesonVal x) b
  pure $ A.Array vs
toAesonVal (ObjectValue b) = do
  vs <- Prelude.mapM (\(k, x) -> do v <- toAesonVal x; pure (k, v)) $ M.toList b
  pure $ A.Object $ HM.fromList vs
toAesonVal _ = throwErr $ CustomRTE "Unserializable value"

waitMillisec :: BuiltInFnWithDoc '[ '("timeinseconds", Number)]
waitMillisec ((coerce -> number) :> _) = (liftIO $ waitMillisec' number) >> pure Nothing

waitForKey :: BuiltInFnWithDoc '[]
waitForKey _ = do
  inputChan <- isTerminalEventChan <$> get
  (liftIO $ atomically $ readTChan inputChan) >>= \case
    TerminalKey (KeyChar _ _ _ i) -> do
      pure $ Just $ StringValue $ T.singleton i
    _ -> pure $ Just $ StringValue ""

readChannel :: TChan TerminalEvent -> String -> IO Text
readChannel inputChan c = do
  (liftIO $ atomically $ readTChan inputChan) >>= \case
    TerminalKey (KeyCtrl _ _ _ Return) -> pure $ T.reverse $ T.pack c
    TerminalKey (KeyChar _ _ _ i) -> do
      S.putChar i
      S.hFlush S.stdout
      readChannel inputChan (i:c)
    _ -> readChannel inputChan c

builtinInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)]
builtinInputLine ((coerce -> prompt) :> _) = do
  liftIO $ do
    T.putStrLn prompt
    S.hFlush S.stdout
  inputChan <- isTerminalEventChan <$> get
  (Just . StringValue) <$>  (liftIO $ readChannel inputChan "")

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

valueSize :: BuiltInFnWithDoc '[ '("list_or_map", Value)]
valueSize ((coerce -> v1) :> _) = case v1 of
  ArrayValue v  -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ V.length v
  ObjectValue m -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ M.size m
  v             -> throwErr (UnexpectedType ("Array or Object", v))