Misc.hs

module Interpreter.Lib.Misc where

import Control.Concurrent.STM.TSem
import Control.Concurrent.STM (atomically)
import Control.Monad.IO.Class
import Control.Monad.State.Strict as SM
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as A
import qualified Data.Aeson.KeyMap as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce
import Data.Map as M
import qualified Data.Scientific as S
import Data.Text as T
import Data.Text.Encoding
import Data.Text.IO as T
import Data.Vector as V
import qualified System.IO as S
import qualified System.IO as SIO
import Text.Read (readMaybe)
import Text.Printf (printf)

import Common
import DiffRender.DiffRender
import Interpreter.Common
import UI.Widgets.Common

initCharScreen :: BuiltInFnWithDoc '[]
initCharScreen _ = do
  isTerminalParams <$> get >>= \case
    Just (_, dm) ->  do
      dfr <- liftIO $ emptyDiffRender dm
      SM.modify (\is -> is { isDiffRender = Just dfr })
    Nothing -> throwErr $ CustomRTE "Unknown terminal size"
  pure Nothing

charScreenGoto :: BuiltInFnWithDoc '[ '("x", Int), '("y", Int)]
charScreenGoto ((coerce -> x) :> (coerce -> y) :> _) = do
  isDiffRender <$> get >>= \case
    Just dm ->  SM.modify (\is -> is { isDiffRender = Just $ dfSetCursorPosition x y dm })
    Nothing -> throwErr $ CustomRTE "Char screen not initialized"
  pure Nothing

charScreenPrint :: BuiltInFnWithDoc '[ '("values", Variadic)]
charScreenPrint ((coerce -> Variadic vals) :> _) = do
  isDiffRender <$> get >>= \case
    Just dm ->  dfPutText (Plain (T.concat $ toStringVal <$> vals)) dm
    Nothing -> throwErr $ CustomRTE "Char screen not initialized"
  pure Nothing

charScreenClear :: BuiltInFnWithDoc '[]
charScreenClear _ = do
  isDiffRender <$> get >>= \case
    Just dm ->  dfClear dm
    Nothing -> throwErr $ CustomRTE "Char screen not initialized"
  pure Nothing

charScreenDraw :: BuiltInFnWithDoc '[]
charScreenDraw _ = do
  isDiffRender <$> get >>= \case
    Just dm ->  do
      tp <- isTerminalParams <$> get
      dfr' <- do
        isStdoutLock <$> get >>= \case
          Just sem -> do
            liftIO $ atomically $ waitTSem sem
            d' <- dfDraw tp dm
            liftIO $ atomically $ signalTSem sem
            pure d'
          Nothing -> dfDraw tp dm
      SM.modify (\is -> is { isDiffRender = Just dfr' })
    Nothing -> throwErr $ CustomRTE "Char screen not initialized"
  pure Nothing

toStringValFmt :: (Text, Int,  [Int]) -> Value -> Text
toStringValFmt (s, _, p) v@(NumberValue (NumberInt _)) = amountFormat s p $ toStringVal v
toStringValFmt (s, f, p) (NumberValue (NumberFractional x)) = amountFormat s p $ T.pack $ printf ("%0." Prelude.++ show f Prelude.++ "f") x
toStringValFmt _ v = toStringVal v

printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)]
printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do
  outH <- isOutputHandle <$> get
  tstrFn <- isDefaultPrintParams <$> get >>= \case
    Just p -> pure $ toStringValFmt p
    Nothing -> pure toStringVal
  liftIO $ do
    UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals)
    T.hPutStrLn outH ""
    S.hFlush outH
  pure Nothing

printVal :: BuiltInFnWithDoc '[ '("value", Variadic)]
printVal ((coerce -> (Variadic vals)) :> EmptyArgs) = do
  outH <- isOutputHandle <$> get
  tstrFn <- isDefaultPrintParams <$> get >>= \case
    Just p -> pure $ toStringValFmt p
    Nothing -> pure toStringVal
  liftIO $ do
    UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals)
    S.hFlush outH
  pure Nothing

numberFromString :: BuiltInFnWithDoc '[ '("string", Text)]
numberFromString ((coerce -> (T.unpack -> str)) :> EmptyArgs) = case readMaybe @IntType str  of
  Just i -> pure $ Just $ NumberValue $ NumberInt i
  Nothing  -> case readMaybe @FloatType str of
    Just i -> pure $ Just $ NumberValue $ NumberFractional i
    Nothing -> pure $ throwErr $ CustomRTE "String cannot be converted to a number"

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", TextOrList), '("item", Value)]
contains ((coerce -> v1) :> (coerce -> v2) :> EmptyArgs) = case v1 of
  TCText t -> case v2 of
    StringValue v -> pure $ Just $ BoolValue $ T.isInfixOf v t
    v             -> throwBadArgs [v] "string"
  TCList lst -> pure $ Just $ BoolValue $ V.foldl' fn False lst
    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'

builtInTake :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)]
builtInTake ((coerce -> c) :> (coerce -> vl) :>  EmptyArgs) = case vl of
  TCText t -> pure $ Just $ StringValue $ T.take c t
  TCList l -> pure $ Just $ ArrayValue (V.take c l)

builtInDrop :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)]
builtInDrop ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = case vl of
  TCText t -> pure $ Just $ StringValue $ T.drop c t
  TCList l -> pure $ Just $ ArrayValue (V.drop c l)

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 <- decodeUtf8 <$> (liftIO $ BS.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", EitherError Value), '("alternate", Value)]
builtInTry ((coerce -> evaluation) :>  (coerce -> alternate) :> _) = case evaluation of
  EitherError (Left _)  -> pure $ Just alternate
  EitherError (Right v) -> pure $ Just v

builtInTimestamp :: BuiltInFnWithDoc '[]
builtInTimestamp _ = do
  st <- liftIO getSystemTimestamp
  pure $ Just $ NumberValue $ NumberInt st

serializeJSON :: Value -> InterpretM BS.ByteString
serializeJSON v =
  (BSL.toStrict . A.encode) <$> toAesonVal v

builtInJSONSerialize :: BuiltInFnWithDoc '[ '("value", Value)]
builtInJSONSerialize ((coerce -> (v :: Value)) :> _) =
  (Just . BytesValue ) <$> serializeJSON v

builtInInspect :: BuiltInFnWithDoc '[ '("value", Value)]
builtInInspect ((coerce -> (v :: Value)) :> _) = do
  vText <- (decodeUtf8) <$> serializeJSON v
  interpreterOutput vText
  interpreterOutputFlush
  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 -> throwErr $ CustomRTE ("JSON decoding failed with error:" <> (T.pack err))

builtInDebug :: BuiltInFnWithDoc '[]
builtInDebug _ = do
  SM.modify (\is -> case isRunMode is of
    DebugMode debugEnv -> is { isRunMode = DebugMode (debugEnv { deStepMode = SingleStep }) }
    _ -> is
    )
  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 $ (\(a, b') -> (A.toText a, fromAesonVal b')) <$> (A.toList 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 (A.fromText k, v)) $ M.toList b
  pure $ A.Object $ A.fromList vs
toAesonVal _ = throwErr UnserializeableValue

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

waitForKey :: BuiltInFnWithDoc '[]
waitForKey _ = do
  inputHandle <- isInputHandle <$> get
  c <- liftIO $ SIO.hGetChar inputHandle
  pure $ Just $ StringValue $ T.singleton c

builtinInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)]
builtinInputLine ((coerce -> prompt) :> _) = do
  interpreterOutput prompt
  interpreterOutputFlush
  (Just . StringValue) <$> readInterpreterInputLine

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