{-# 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 [Value]
  | -- | The `Env` may contain the `ValLambda` cyclicly.
    ValLambda (Maybe VarName) Env VarName Type Expr
  deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, ReadPrec [Value]
ReadPrec Value
Int -> ReadS Value
ReadS [Value]
(Int -> ReadS Value)
-> ReadS [Value]
-> ReadPrec Value
-> ReadPrec [Value]
-> Read Value
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Value]
$creadListPrec :: ReadPrec [Value]
readPrec :: ReadPrec Value
$creadPrec :: ReadPrec Value
readList :: ReadS [Value]
$creadList :: ReadS [Value]
readsPrec :: Int -> ReadS Value
$creadsPrec :: Int -> ReadS Value
Read)

type Env = [(VarName, Value)]

literalToValue :: MonadError Error m => Literal -> m Value
literalToValue :: Literal -> m Value
literalToValue = \case
  LitBuiltin Builtin
builtin -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Builtin -> [Value] -> Value
ValBuiltin Builtin
builtin []
  LitInt Integer
n -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
ValInt Integer
n
  LitBool Bool
p -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
ValBool Bool
p
  LitNil Type
_ -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Vector Value -> Value
ValList Vector Value
forall a. Vector a
V.empty
  LitBottom Type
_ String
err -> String -> m Value
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwRuntimeError String
err

valueToInt :: MonadError Error m => Value -> m Integer
valueToInt :: Value -> m Integer
valueToInt = \case
  ValInt Integer
n -> Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  Value
val -> String -> m Integer
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m Integer) -> String -> m Integer
forall a b. (a -> b) -> a -> b
$ String
"not an integer value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToList :: MonadError Error m => Value -> m (V.Vector Value)
valueToList :: Value -> m (Vector Value)
valueToList = \case
  ValList Vector Value
xs -> Vector Value -> m (Vector Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector Value
xs
  Value
val -> String -> m (Vector Value)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m (Vector Value)) -> String -> m (Vector Value)
forall a b. (a -> b) -> a -> b
$ String
"not a list value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToIntList :: MonadError Error m => Value -> m [Integer]
valueToIntList :: Value -> m [Integer]
valueToIntList Value
xs = (Value -> m Integer) -> [Value] -> m [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt ([Value] -> m [Integer])
-> (Vector Value -> [Value]) -> Vector Value -> m [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList (Vector Value -> m [Integer]) -> m (Vector Value) -> m [Integer]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
valueToList Value
xs

valueToBool :: MonadError Error m => Value -> m Bool
valueToBool :: Value -> m Bool
valueToBool = \case
  ValBool Bool
p -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
p
  Value
val -> String -> m Bool
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String
"not an boolean value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToBoolList :: MonadError Error m => Value -> m [Bool]
valueToBoolList :: Value -> m [Bool]
valueToBoolList Value
xs = (Value -> m Bool) -> [Value] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> m Bool
forall (m :: * -> *). MonadError Error m => Value -> m Bool
valueToBool ([Value] -> m [Bool])
-> (Vector Value -> [Value]) -> Vector Value -> m [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList (Vector Value -> m [Bool]) -> m (Vector Value) -> m [Bool]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
valueToList Value
xs

valueToTuple :: MonadError Error m => Value -> m [Value]
valueToTuple :: Value -> m [Value]
valueToTuple = \case
  ValTuple [Value]
xs -> [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
xs
  Value
val -> String -> m [Value]
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m [Value]) -> String -> m [Value]
forall a b. (a -> b) -> a -> b
$ String
"not a tuple value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToIntPair :: MonadError Error m => Value -> m (Integer, Integer)
valueToIntPair :: Value -> m (Integer, Integer)
valueToIntPair = \case
  ValTuple [Value
a, Value
b] -> (,) (Integer -> Integer -> (Integer, Integer))
-> m Integer -> m (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt Value
a m (Integer -> (Integer, Integer))
-> m Integer -> m (Integer, Integer)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt Value
b
  Value
val -> String -> m (Integer, Integer)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m (Integer, Integer)) -> String -> m (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ String
"not a tuple value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToVector :: MonadError Error m => Value -> m (V.Vector Integer)
valueToVector :: Value -> m (Vector Integer)
valueToVector = \case
  ValTuple [Value]
x -> [Integer] -> Vector Integer
forall a. [a] -> Vector a
V.fromList ([Integer] -> Vector Integer) -> m [Integer] -> m (Vector Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> m Integer) -> [Value] -> m [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt [Value]
x
  Value
val -> String -> m (Vector Integer)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m (Vector Integer)) -> String -> m (Vector Integer)
forall a b. (a -> b) -> a -> b
$ String
"not a vector: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
val

valueToMatrix :: MonadError Error m => Value -> m (Matrix Integer)
valueToMatrix :: Value -> m (Matrix Integer)
valueToMatrix Value
a = do
  Vector (Vector Integer)
a <- (Value -> m (Vector Integer))
-> Vector Value -> m (Vector (Vector Integer))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Value -> m (Vector Integer)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Integer)
valueToVector (Vector Value -> m (Vector (Vector Integer)))
-> ([Value] -> Vector Value)
-> [Value]
-> m (Vector (Vector Integer))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList ([Value] -> m (Vector (Vector Integer)))
-> m [Value] -> m (Vector (Vector Integer))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> m [Value]
forall (m :: * -> *). MonadError Error m => Value -> m [Value]
valueToTuple Value
a
  case Vector (Vector Integer) -> Maybe (Matrix Integer)
forall a. Vector (Vector a) -> Maybe (Matrix a)
makeMatrix Vector (Vector Integer)
a of
    Just Matrix Integer
a -> Matrix Integer -> m (Matrix Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Matrix Integer
a
    Maybe (Matrix Integer)
Nothing -> String -> m (Matrix Integer)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m (Matrix Integer)) -> String -> m (Matrix Integer)
forall a b. (a -> b) -> a -> b
$ String
"not a matrix: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Vector (Vector Integer) -> String
forall a. Show a => a -> String
show Vector (Vector Integer)
a

valueFromVector :: V.Vector Integer -> Value
valueFromVector :: Vector Integer -> Value
valueFromVector Vector Integer
x = [Value] -> Value
ValTuple ((Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Value
ValInt (Vector Integer -> [Integer]
forall a. Vector a -> [a]
V.toList Vector Integer
x))

valueFromMatrix :: Matrix Integer -> Value
valueFromMatrix :: Matrix Integer -> Value
valueFromMatrix Matrix Integer
f = [Value] -> Value
ValTuple ((Vector Integer -> Value) -> [Vector Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ([Value] -> Value
ValTuple ([Value] -> Value)
-> (Vector Integer -> [Value]) -> Vector Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Value
ValInt ([Integer] -> [Value])
-> (Vector Integer -> [Integer]) -> Vector Integer -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Integer -> [Integer]
forall a. Vector a -> [a]
V.toList) (Vector (Vector Integer) -> [Vector Integer]
forall a. Vector a -> [a]
V.toList (Matrix Integer -> Vector (Vector Integer)
forall a. Matrix a -> Vector (Vector a)
unMatrix Matrix Integer
f)))

valueToModVector :: MonadError Error m => Integer -> Value -> m (V.Vector ModInt)
valueToModVector :: Integer -> Value -> m (Vector ModInt)
valueToModVector Integer
m Value
x = (Integer -> ModInt) -> Vector Integer -> Vector ModInt
forall a b. (a -> b) -> Vector a -> Vector b
V.map (Integer -> Integer -> ModInt
`toModInt` Integer
m) (Vector Integer -> Vector ModInt)
-> m (Vector Integer) -> m (Vector ModInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Vector Integer)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Integer)
valueToVector Value
x

valueToModMatrix :: MonadError Error m => Integer -> Value -> m (Matrix ModInt)
valueToModMatrix :: Integer -> Value -> m (Matrix ModInt)
valueToModMatrix Integer
m Value
f = (Integer -> ModInt) -> Matrix Integer -> Matrix ModInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> ModInt
`toModInt` Integer
m) (Matrix Integer -> Matrix ModInt)
-> m (Matrix Integer) -> m (Matrix ModInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Matrix Integer)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Matrix Integer)
valueToMatrix Value
f

valueFromModVector :: V.Vector ModInt -> Value
valueFromModVector :: Vector ModInt -> Value
valueFromModVector = Vector Integer -> Value
valueFromVector (Vector Integer -> Value)
-> (Vector ModInt -> Vector Integer) -> Vector ModInt -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModInt -> Integer) -> Vector ModInt -> Vector Integer
forall a b. (a -> b) -> Vector a -> Vector b
V.map ModInt -> Integer
fromModInt

valueFromModMatrix :: Matrix ModInt -> Value
valueFromModMatrix :: Matrix ModInt -> Value
valueFromModMatrix = Matrix Integer -> Value
valueFromMatrix (Matrix Integer -> Value)
-> (Matrix ModInt -> Matrix Integer) -> Matrix ModInt -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModInt -> Integer) -> Matrix ModInt -> Matrix Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModInt -> Integer
fromModInt

compareValues :: Value -> Value -> Maybe Ordering
compareValues :: Value -> Value -> Maybe Ordering
compareValues Value
a Value
b = case (Value
a, Value
b) of
  (ValInt Integer
a, ValInt Integer
b) -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
a Integer
b)
  (ValBool Bool
a, ValBool Bool
b) -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
a Bool
b)
  (ValList Vector Value
a, ValList Vector Value
b) -> case [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat ([Ordering] -> Ordering) -> Maybe [Ordering] -> Maybe Ordering
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Value -> Maybe Ordering)
-> [Value] -> [Value] -> Maybe [Ordering]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Value -> Value -> Maybe Ordering
compareValues (Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList Vector Value
a) (Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList Vector Value
b) of
    Just Ordering
EQ -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Vector Value -> Int
forall a. Vector a -> Int
V.length Vector Value
a) (Vector Value -> Int
forall a. Vector a -> Int
V.length Vector Value
b))
    Maybe Ordering
ordering -> Maybe Ordering
ordering
  (ValTuple [Value]
a, ValTuple [Value]
b) -> [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat ([Ordering] -> Ordering) -> Maybe [Ordering] -> Maybe Ordering
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Value -> Maybe Ordering)
-> [Value] -> [Value] -> Maybe [Ordering]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Value -> Value -> Maybe Ordering
compareValues [Value]
a [Value]
b
  (Value
_, Value
_) -> Maybe Ordering
forall a. Maybe a
Nothing

compareValues' :: Value -> Value -> Ordering
compareValues' :: Value -> Value -> Ordering
compareValues' Value
a Value
b = Ordering -> Maybe Ordering -> Ordering
forall a. a -> Maybe a -> a
fromMaybe Ordering
EQ (Value -> Value -> Maybe Ordering
compareValues Value
a Value
b)

minValue :: Value -> Value -> Value
minValue :: Value -> Value -> Value
minValue Value
a Value
b = if Value -> Value -> Ordering
compareValues' Value
a Value
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT then Value
a else Value
b

maxValue :: Value -> Value -> Value
maxValue :: Value -> Value -> Value
maxValue Value
a Value
b = if Value -> Value -> Ordering
compareValues' Value
a Value
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT then Value
a else Value
b

formatValue :: Value -> String
formatValue :: Value -> String
formatValue = \case
  ValInt Integer
n -> Integer -> String
forall a. Show a => a -> String
show Integer
n
  ValBool Bool
p -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Bool -> String
forall a. Show a => a -> String
show Bool
p)
  ValList Vector Value
xs -> String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
formatValue (Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList Vector Value
xs)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  ValTuple [Value
x] -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",)"
  ValTuple [Value]
xs -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
formatValue [Value]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  ValBuiltin Builtin
builtin [] -> Builtin -> String
formatBuiltinIsolated Builtin
builtin
  ValBuiltin Builtin
builtin [Value]
args -> Builtin -> String
formatBuiltinIsolated Builtin
builtin String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
formatValue [Value]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  ValLambda Maybe VarName
_ Env
_ VarName
x Type
t Expr
body -> Expr -> String
formatExpr (VarName -> Type -> Expr -> Expr
Lam VarName
x Type
t Expr
body) -- Don't show env because it may be cyclic.

readValueIO :: (MonadError Error m, MonadIO m) => IOFormat -> m ([Value], M.Map String Value)
readValueIO :: IOFormat -> m ([Value], Map String Value)
readValueIO = (Value -> m Integer)
-> (Integer -> Value)
-> (Value -> m (Vector Value))
-> (Vector Value -> Value)
-> IOFormat
-> m ([Value], Map String Value)
forall (m :: * -> *) value.
(MonadError Error m, MonadIO m) =>
(value -> m Integer)
-> (Integer -> value)
-> (value -> m (Vector value))
-> (Vector value -> value)
-> IOFormat
-> m ([value], Map String value)
makeReadValueIO Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt Integer -> Value
ValInt Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
valueToList Vector Value -> Value
ValList

writeValueIO :: (MonadError Error m, MonadIO m) => IOFormat -> M.Map String Value -> Value -> m ()
writeValueIO :: IOFormat -> Map String Value -> Value -> m ()
writeValueIO = (Value -> m [Value])
-> (Integer -> Value)
-> (Value -> m Integer)
-> (Value -> m (Vector Value))
-> IOFormat
-> Map String Value
-> Value
-> m ()
forall (m :: * -> *) value.
(MonadError Error m, MonadIO m) =>
(value -> m [value])
-> (Integer -> value)
-> (value -> m Integer)
-> (value -> m (Vector value))
-> IOFormat
-> Map String value
-> value
-> m ()
makeWriteValueIO Value -> m [Value]
forall (m :: * -> *). MonadError Error m => Value -> m [Value]
valueToTuple Integer -> Value
ValInt Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
valueToInt Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
valueToList