{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Jikka.RestrictedPython.Language.Value where

import Data.Char (toLower)
import Data.List (intercalate)
import qualified Data.Map.Strict 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.RestrictedPython.Language.Expr

-- | `Value` is the values of our restricted Python-like language.
--
-- \[
--     \begin{array}{rl}
--         v ::= & \dots, -2, -1, 0, 1, 2, \dots \\
--         \vert & \mathbf{false}, \mathbf{true} \\
--         \vert & \mathbf{nil} \\
--         \vert & \mathbf{cons}(v, v) \\
--         \vert & (v, v, \dots, v) \\
--         \vert & \lambda _ \mu x x \dots x. e \\
--         \vert & \mathrm{builtin} \\
--     \end{array}
-- \]
data Value
  = IntVal Integer
  | BoolVal Bool
  | ListVal (V.Vector Value)
  | TupleVal [Value]
  | ClosureVal Local [(VarName, Type)] [Statement]
  | BuiltinVal Builtin
  | AttributeVal Value Attribute
  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, Eq Value
Eq Value
-> (Value -> Value -> Ordering)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Value)
-> (Value -> Value -> Value)
-> Ord Value
Value -> Value -> Bool
Value -> Value -> Ordering
Value -> Value -> Value
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmax :: Value -> Value -> Value
>= :: Value -> Value -> Bool
$c>= :: Value -> Value -> Bool
> :: Value -> Value -> Bool
$c> :: Value -> Value -> Bool
<= :: Value -> Value -> Bool
$c<= :: Value -> Value -> Bool
< :: Value -> Value -> Bool
$c< :: Value -> Value -> Bool
compare :: Value -> Value -> Ordering
$ccompare :: Value -> Value -> Ordering
$cp1Ord :: Eq Value
Ord, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, 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)

newtype Local = Local
  { Local -> Map VarName Value
unLocal :: M.Map VarName Value
  }
  deriving (Local -> Local -> Bool
(Local -> Local -> Bool) -> (Local -> Local -> Bool) -> Eq Local
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Local -> Local -> Bool
$c/= :: Local -> Local -> Bool
== :: Local -> Local -> Bool
$c== :: Local -> Local -> Bool
Eq, Eq Local
Eq Local
-> (Local -> Local -> Ordering)
-> (Local -> Local -> Bool)
-> (Local -> Local -> Bool)
-> (Local -> Local -> Bool)
-> (Local -> Local -> Bool)
-> (Local -> Local -> Local)
-> (Local -> Local -> Local)
-> Ord Local
Local -> Local -> Bool
Local -> Local -> Ordering
Local -> Local -> Local
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Local -> Local -> Local
$cmin :: Local -> Local -> Local
max :: Local -> Local -> Local
$cmax :: Local -> Local -> Local
>= :: Local -> Local -> Bool
$c>= :: Local -> Local -> Bool
> :: Local -> Local -> Bool
$c> :: Local -> Local -> Bool
<= :: Local -> Local -> Bool
$c<= :: Local -> Local -> Bool
< :: Local -> Local -> Bool
$c< :: Local -> Local -> Bool
compare :: Local -> Local -> Ordering
$ccompare :: Local -> Local -> Ordering
$cp1Ord :: Eq Local
Ord, Int -> Local -> ShowS
[Local] -> ShowS
Local -> String
(Int -> Local -> ShowS)
-> (Local -> String) -> ([Local] -> ShowS) -> Show Local
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Local] -> ShowS
$cshowList :: [Local] -> ShowS
show :: Local -> String
$cshow :: Local -> String
showsPrec :: Int -> Local -> ShowS
$cshowsPrec :: Int -> Local -> ShowS
Show, ReadPrec [Local]
ReadPrec Local
Int -> ReadS Local
ReadS [Local]
(Int -> ReadS Local)
-> ReadS [Local]
-> ReadPrec Local
-> ReadPrec [Local]
-> Read Local
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Local]
$creadListPrec :: ReadPrec [Local]
readPrec :: ReadPrec Local
$creadPrec :: ReadPrec Local
readList :: ReadS [Local]
$creadList :: ReadS [Local]
readsPrec :: Int -> ReadS Local
$creadsPrec :: Int -> ReadS Local
Read)

toInt :: MonadError Error m => Value -> m Integer
toInt :: Value -> m Integer
toInt = \case
  IntVal Integer
n -> Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  Value
v -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
v

toBool :: MonadError Error m => Value -> m Bool
toBool :: Value -> m Bool
toBool = \case
  BoolVal Bool
p -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
p
  Value
v -> 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 a boolean value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
v

toList :: MonadError Error m => Value -> m (V.Vector Value)
toList :: Value -> m (Vector Value)
toList = \case
  ListVal Vector Value
xs -> Vector Value -> m (Vector Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector Value
xs
  Value
v -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
v

toTuple :: MonadError Error m => Value -> m [Value]
toTuple :: Value -> m [Value]
toTuple = \case
  TupleVal [Value]
xs -> [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
xs
  Value
v -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
v

toIntList :: MonadError Error m => Value -> m (V.Vector Integer)
toIntList :: Value -> m (Vector Integer)
toIntList Value
xs = (Value -> m Integer) -> Vector Value -> m (Vector Integer)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
toInt (Vector Value -> m (Vector Integer))
-> m (Vector Value) -> m (Vector 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)
toList Value
xs

toBoolList :: MonadError Error m => Value -> m (V.Vector Bool)
toBoolList :: Value -> m (Vector Bool)
toBoolList Value
xs = (Value -> m Bool) -> Vector Value -> m (Vector Bool)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Value -> m Bool
forall (m :: * -> *). MonadError Error m => Value -> m Bool
toBool (Vector Value -> m (Vector Bool))
-> m (Vector Value) -> m (Vector 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)
toList Value
xs

toMatrix :: MonadError Error m => Value -> m (Matrix Integer)
toMatrix :: Value -> m (Matrix Integer)
toMatrix Value
a = Vector (Vector Integer) -> m (Matrix Integer)
forall (m :: * -> *) a.
(MonadError Error m, Show a) =>
Vector (Vector a) -> m (Matrix a)
toMatrix' (Vector (Vector Integer) -> m (Matrix Integer))
-> m (Vector (Vector Integer)) -> m (Matrix Integer)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (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)
toIntList (Vector Value -> m (Vector (Vector Integer)))
-> m (Vector Value) -> m (Vector (Vector 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)
toList Value
a
  where
    toMatrix' :: Vector (Vector a) -> m (Matrix a)
toMatrix' Vector (Vector a)
a = case Vector (Vector a) -> Maybe (Matrix a)
forall a. Vector (Vector a) -> Maybe (Matrix a)
makeMatrix Vector (Vector a)
a of
      Just Matrix a
a -> Matrix a -> m (Matrix a)
forall (m :: * -> *) a. Monad m => a -> m a
return Matrix a
a
      Maybe (Matrix a)
Nothing -> String -> m (Matrix a)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m (Matrix a)) -> String -> m (Matrix a)
forall a b. (a -> b) -> a -> b
$ String
"not a matrix: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vector (Vector a) -> String
forall a. Show a => a -> String
show Vector (Vector a)
a

fromMatrix :: Matrix Integer -> Value
fromMatrix :: Matrix Integer -> Value
fromMatrix Matrix Integer
a = Vector Value -> Value
ListVal ((Vector Integer -> Value)
-> Vector (Vector Integer) -> Vector Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector Value -> Value
ListVal (Vector Value -> Value)
-> (Vector Integer -> Vector Value) -> Vector Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Value) -> Vector Integer -> Vector Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Value
IntVal) (Matrix Integer -> Vector (Vector Integer)
forall a. Matrix a -> Vector (Vector a)
unMatrix Matrix Integer
a))

compareValues :: Value -> Value -> Maybe Ordering
compareValues :: Value -> Value -> Maybe Ordering
compareValues Value
a Value
b = case (Value
a, Value
b) of
  (IntVal Integer
a, IntVal Integer
b) -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
a Integer
b
  (BoolVal Bool
a, BoolVal Bool
b) -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
a Bool
b
  (ListVal Vector Value
a, ListVal Vector Value
b) -> case [Maybe Ordering] -> Maybe Ordering
forall a. Monoid a => [a] -> a
mconcat (Vector (Maybe Ordering) -> [Maybe Ordering]
forall a. Vector a -> [a]
V.toList ((Value -> Value -> Maybe Ordering)
-> Vector Value -> Vector Value -> Vector (Maybe Ordering)
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith Value -> Value -> Maybe Ordering
compareValues Vector Value
a Vector Value
b)) of
    Maybe Ordering
Nothing -> Maybe Ordering
forall a. Maybe a
Nothing
    Just Ordering
EQ -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ 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)
    Just Ordering
o -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
o
  (TupleVal [Value]
a, TupleVal [Value]
b) ->
    if [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
b
      then Maybe Ordering
forall a. Maybe a
Nothing
      else [Maybe Ordering] -> Maybe Ordering
forall a. Monoid a => [a] -> a
mconcat ((Value -> Value -> Maybe Ordering)
-> [Value] -> [Value] -> [Maybe Ordering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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)

formatValue :: Value -> String
formatValue :: Value -> String
formatValue = \case
  IntVal Integer
n -> Integer -> String
forall a. Show a => a -> String
show Integer
n
  BoolVal Bool
p -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Bool -> String
forall a. Show a => a -> String
show Bool
p)
  ListVal Vector Value
xs -> String
"[" String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
  TupleVal [Value
x] -> String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",)"
  TupleVal [Value]
xs -> String
"(" String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  f :: Value
f@ClosureVal {} -> Value -> String
forall a. Show a => a -> String
show Value
f
  BuiltinVal Builtin
b -> Builtin -> String
forall a. Show a => a -> String
show Builtin
b
  AttributeVal Value
x Attribute
a -> String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
formatValue Value
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Attribute -> String
forall a. Show a => a -> String
show Attribute
a

readValueIO :: (MonadIO m, MonadError Error 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
toInt Integer -> Value
IntVal Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
toList Vector Value -> Value
ListVal

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]
toTuple Integer -> Value
IntVal Value -> m Integer
forall (m :: * -> *). MonadError Error m => Value -> m Integer
toInt Value -> m (Vector Value)
forall (m :: * -> *).
MonadError Error m =>
Value -> m (Vector Value)
toList