content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE LambdaCase #-}
  
  module Jikka.Core.Language.Value where
  
  import Data.Char (toLower)
  import Data.List (intercalate)
  import qualified Data.Map as M
  import Data.Maybe (fromMaybe)
  import qualified Data.Vector as V
  import Jikka.Common.Error
  import Jikka.Common.IOFormat
  import Jikka.Common.Matrix
  import Jikka.Common.ModInt
  import Jikka.Core.Format (formatBuiltinIsolated, formatExpr)
  import Jikka.Core.Language.Expr
  
  data Value
    = ValInt Integer
    | ValBool Bool
    | ValList (V.Vector Value)
    | ValTuple [Value]
    | ValBuiltin Builtin [Type] [Value]
    | -- | The `Env` may contain the `ValLambda` cyclicly.
      ValLambda (Maybe VarName) Env VarName Type Expr
    deriving (Eq, Read)
  
  type Env = [(VarName, Value)]
  
  literalToValue :: MonadError Error m => Literal -> m Value
  literalToValue = \case
    LitBuiltin builtin ts -> return $ ValBuiltin builtin ts []
    LitInt n -> return $ ValInt n
    LitBool p -> return $ ValBool p
    LitNil _ -> return $ ValList V.empty
    LitBottom _ err -> throwRuntimeError err
  
  valueToInt :: MonadError Error m => Value -> m Integer
  valueToInt = \case
    ValInt n -> return n
    val -> throwInternalError $ "not an integer value: " ++ formatValue val
  
  valueToList :: MonadError Error m => Value -> m (V.Vector Value)
  valueToList = \case
    ValList xs -> return xs
    val -> throwInternalError $ "not a list value: " ++ formatValue val
  
  valueToIntList :: MonadError Error m => Value -> m [Integer]
  valueToIntList xs = mapM valueToInt . V.toList =<< valueToList xs
  
  valueToBool :: MonadError Error m => Value -> m Bool
  valueToBool = \case
    ValBool p -> return p
    val -> throwInternalError $ "not an boolean value: " ++ formatValue val
  
  valueToBoolList :: MonadError Error m => Value -> m [Bool]
  valueToBoolList xs = mapM valueToBool . V.toList =<< valueToList xs
  
  valueToTuple :: MonadError Error m => Value -> m [Value]
  valueToTuple = \case
    ValTuple xs -> return xs
    val -> throwInternalError $ "not a tuple value: " ++ formatValue val
  
  valueToIntPair :: MonadError Error m => Value -> m (Integer, Integer)
  valueToIntPair = \case
    ValTuple [a, b] -> (,) <$> valueToInt a <*> valueToInt b
    val -> throwInternalError $ "not a tuple value: " ++ formatValue val
  
  valueToVector :: MonadError Error m => Value -> m (V.Vector Integer)
  valueToVector = \case
    ValTuple x -> V.fromList <$> mapM valueToInt x
    val -> throwInternalError $ "not a vector: " ++ formatValue val
  
  valueToMatrix :: MonadError Error m => Value -> m (Matrix Integer)
  valueToMatrix a = do
    a <- V.mapM valueToVector . V.fromList =<< valueToTuple a
    case makeMatrix a of
      Just a -> return a
      Nothing -> throwInternalError $ "not a matrix: " ++ show a
  
  valueFromVector :: V.Vector Integer -> Value
  valueFromVector x = ValTuple (map ValInt (V.toList x))
  
  valueFromMatrix :: Matrix Integer -> Value
  valueFromMatrix f = ValTuple (map (ValTuple . map ValInt . V.toList) (V.toList (unMatrix f)))
  
  valueToModVector :: MonadError Error m => Integer -> Value -> m (V.Vector ModInt)
  valueToModVector m x = V.map (`toModInt` m) <$> valueToVector x
  
  valueToModMatrix :: MonadError Error m => Integer -> Value -> m (Matrix ModInt)
  valueToModMatrix m f = fmap (`toModInt` m) <$> valueToMatrix f
  
  valueFromModVector :: V.Vector ModInt -> Value
  valueFromModVector = valueFromVector . V.map fromModInt
  
  valueFromModMatrix :: Matrix ModInt -> Value
  valueFromModMatrix = valueFromMatrix . fmap fromModInt
  
  compareValues :: Value -> Value -> Maybe Ordering
  compareValues a b = case (a, b) of
    (ValInt a, ValInt b) -> Just (compare a b)
    (ValBool a, ValBool b) -> Just (compare a b)
    (ValList a, ValList b) -> case mconcat <$> zipWithM compareValues (V.toList a) (V.toList b) of
      Just EQ -> Just (compare (V.length a) (V.length b))
      ordering -> ordering
    (ValTuple a, ValTuple b) -> mconcat <$> zipWithM compareValues a b
    (_, _) -> Nothing
  
  compareValues' :: Value -> Value -> Ordering
  compareValues' a b = fromMaybe EQ (compareValues a b)
  
  minValue :: Value -> Value -> Value
  minValue a b = if compareValues' a b == LT then a else b
  
  maxValue :: Value -> Value -> Value
  maxValue a b = if compareValues' a b == GT then a else b
  
  formatValue :: Value -> String
  formatValue = \case
    ValInt n -> show n
    ValBool p -> map toLower (show p)
    ValList xs -> "[" ++ intercalate ", " (map formatValue (V.toList xs)) ++ "]"
    ValTuple [x] -> "(" ++ formatValue x ++ ",)"
    ValTuple xs -> "(" ++ intercalate ", " (map formatValue xs) ++ ")"
    ValBuiltin builtin ts [] -> formatBuiltinIsolated builtin ts
    ValBuiltin builtin ts args -> formatBuiltinIsolated builtin ts ++ "(" ++ intercalate ", " (map formatValue args) ++ ")"
    ValLambda _ _ x t body -> formatExpr (Lam x t body) -- Don't show env because it may be cyclic.
  
  readValueIO :: (MonadError Error m, MonadIO m) => IOFormat -> m ([Value], M.Map String Value)
  readValueIO = makeReadValueIO valueToInt ValInt valueToList ValList
  
  writeValueIO :: (MonadError Error m, MonadIO m) => IOFormat -> M.Map String Value -> Value -> m ()
  writeValueIO = makeWriteValueIO valueToTuple ValInt valueToInt valueToList
  