{-# LANGUAGE FlexibleContexts #-}

{- |
Module      : Language.Egison.Primitives
Licence     : MIT

This module provides primitive functions in Egison.
-}

module Language.Egison.Primitives
  ( primitiveEnv
  , primitiveEnvNoIO
  ) where

import           Control.Monad                     (forM)
import           Control.Monad.IO.Class            (liftIO)

import           Data.IORef
import           Data.List                         (lookup)
import           Data.Foldable                     (toList)

import qualified Data.Sequence                     as Sq
import qualified Data.Vector                       as V

 {--  -- for 'egison-sqlite'
import qualified Database.SQLite3 as SQLite
 --}  -- for 'egison-sqlite'

import           Language.Egison.Data
import           Language.Egison.Data.Collection   (makeICollection)
import           Language.Egison.IExpr             (Index (..), stringToVar)
import           Language.Egison.Math
import           Language.Egison.Primitives.Arith
import           Language.Egison.Primitives.IO
import           Language.Egison.Primitives.String
import           Language.Egison.Primitives.Types
import           Language.Egison.Primitives.Utils

primitiveEnv :: IO Env
primitiveEnv :: IO Env
primitiveEnv = do
  [(Var, IORef Object)]
bindings <- [(String, EgisonValue)]
-> ((String, EgisonValue) -> IO (Var, IORef Object))
-> IO [(Var, IORef Object)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(String, EgisonValue)]
constants [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
primitives [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
ioPrimitives) (((String, EgisonValue) -> IO (Var, IORef Object))
 -> IO [(Var, IORef Object)])
-> ((String, EgisonValue) -> IO (Var, IORef Object))
-> IO [(Var, IORef Object)]
forall a b. (a -> b) -> a -> b
$ \(String
name, EgisonValue
op) -> do
    IORef Object
ref <- Object -> IO (IORef Object)
forall a. a -> IO (IORef a)
newIORef (Object -> IO (IORef Object))
-> (WHNFData -> Object) -> WHNFData -> IO (IORef Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WHNFData -> Object
WHNF (WHNFData -> IO (IORef Object)) -> WHNFData -> IO (IORef Object)
forall a b. (a -> b) -> a -> b
$ EgisonValue -> WHNFData
Value EgisonValue
op
    (Var, IORef Object) -> IO (Var, IORef Object)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Var
stringToVar String
name, IORef Object
ref)
  Env -> IO Env
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [(Var, IORef Object)] -> Env
extendEnv Env
nullEnv [(Var, IORef Object)]
bindings

primitiveEnvNoIO :: IO Env
primitiveEnvNoIO :: IO Env
primitiveEnvNoIO = do
  [(Var, IORef Object)]
bindings <- [(String, EgisonValue)]
-> ((String, EgisonValue) -> IO (Var, IORef Object))
-> IO [(Var, IORef Object)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(String, EgisonValue)]
constants [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
primitives) (((String, EgisonValue) -> IO (Var, IORef Object))
 -> IO [(Var, IORef Object)])
-> ((String, EgisonValue) -> IO (Var, IORef Object))
-> IO [(Var, IORef Object)]
forall a b. (a -> b) -> a -> b
$ \(String
name, EgisonValue
op) -> do
    IORef Object
ref <- Object -> IO (IORef Object)
forall a. a -> IO (IORef a)
newIORef (Object -> IO (IORef Object))
-> (WHNFData -> Object) -> WHNFData -> IO (IORef Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WHNFData -> Object
WHNF (WHNFData -> IO (IORef Object)) -> WHNFData -> IO (IORef Object)
forall a b. (a -> b) -> a -> b
$ EgisonValue -> WHNFData
Value EgisonValue
op
    (Var, IORef Object) -> IO (Var, IORef Object)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Var
stringToVar String
name, IORef Object
ref)
  Env -> IO Env
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [(Var, IORef Object)] -> Env
extendEnv Env
nullEnv [(Var, IORef Object)]
bindings

--
-- Constants
--

constants :: [(String, EgisonValue)]
constants :: [(String, EgisonValue)]
constants = [ (String
"f.pi", Double -> EgisonValue
Float Double
3.141592653589793)
            , (String
"f.e" , Double -> EgisonValue
Float Double
2.718281828459045)
            ]

--
-- Primitives
--

primitives :: [(String, EgisonValue)]
primitives :: [(String, EgisonValue)]
primitives =
  ((String, String -> PrimitiveFunc) -> (String, EgisonValue))
-> [(String, String -> PrimitiveFunc)] -> [(String, EgisonValue)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, String -> PrimitiveFunc
fn) -> (String
name, PrimitiveFunc -> EgisonValue
PrimitiveFunc (String -> PrimitiveFunc
fn String
name))) [(String, String -> PrimitiveFunc)]
strictPrimitives
  [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ ((String, String -> LazyPrimitiveFunc) -> (String, EgisonValue))
-> [(String, String -> LazyPrimitiveFunc)]
-> [(String, EgisonValue)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, String -> LazyPrimitiveFunc
fn) -> (String
name, LazyPrimitiveFunc -> EgisonValue
LazyPrimitiveFunc (String -> LazyPrimitiveFunc
fn String
name))) [(String, String -> LazyPrimitiveFunc)]
lazyPrimitives
  [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
primitiveArithFunctions
  [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
primitiveStringFunctions
  [(String, EgisonValue)]
-> [(String, EgisonValue)] -> [(String, EgisonValue)]
forall a. [a] -> [a] -> [a]
++ [(String, EgisonValue)]
primitiveTypeFunctions
    where
      strictPrimitives :: [(String, String -> PrimitiveFunc)]
strictPrimitives =
        [ (String
"addSubscript", String -> PrimitiveFunc
addSubscript)
        , (String
"addSuperscript", String -> PrimitiveFunc
addSuperscript)

        , (String
"assert",      String -> PrimitiveFunc
assert)
        , (String
"assertEqual", String -> PrimitiveFunc
assertEqual)
        
        , (String
"sortWithSign", String -> PrimitiveFunc
sortWithSign)
        , (String
"updateFunctionArgs", String -> PrimitiveFunc
updateFunctionArgs)
        ]
      lazyPrimitives :: [(String, String -> LazyPrimitiveFunc)]
lazyPrimitives =
        [ (String
"tensorShape", String -> LazyPrimitiveFunc
tensorShape')
        , (String
"tensorToList", String -> LazyPrimitiveFunc
tensorToList')
        , (String
"dfOrder", String -> LazyPrimitiveFunc
dfOrder')
        ]

--
-- Miscellaneous primitive functions
--

tensorShape' :: String -> LazyPrimitiveFunc
tensorShape' :: String -> LazyPrimitiveFunc
tensorShape' = (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc
lazyOneArg WHNFData -> EvalM WHNFData
forall {m :: * -> *}. Monad m => WHNFData -> m WHNFData
tensorShape''
 where
  tensorShape'' :: WHNFData -> m WHNFData
tensorShape'' (Value (TensorData (Tensor [Integer]
ns Vector EgisonValue
_ [Index EgisonValue]
_))) =
    WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData)
-> ([EgisonValue] -> WHNFData) -> [EgisonValue] -> m WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EgisonValue -> WHNFData
Value (EgisonValue -> WHNFData)
-> ([EgisonValue] -> EgisonValue) -> [EgisonValue] -> WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EgisonValue -> EgisonValue
Collection (Seq EgisonValue -> EgisonValue)
-> ([EgisonValue] -> Seq EgisonValue)
-> [EgisonValue]
-> EgisonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ([EgisonValue] -> m WHNFData) -> [EgisonValue] -> m WHNFData
forall a b. (a -> b) -> a -> b
$ (Integer -> EgisonValue) -> [Integer] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison [Integer]
ns
  tensorShape'' (ITensor (Tensor [Integer]
ns Vector (IORef Object)
_ [Index EgisonValue]
_)) =
    WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData)
-> ([EgisonValue] -> WHNFData) -> [EgisonValue] -> m WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EgisonValue -> WHNFData
Value (EgisonValue -> WHNFData)
-> ([EgisonValue] -> EgisonValue) -> [EgisonValue] -> WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EgisonValue -> EgisonValue
Collection (Seq EgisonValue -> EgisonValue)
-> ([EgisonValue] -> Seq EgisonValue)
-> [EgisonValue]
-> EgisonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ([EgisonValue] -> m WHNFData) -> [EgisonValue] -> m WHNFData
forall a b. (a -> b) -> a -> b
$ (Integer -> EgisonValue) -> [Integer] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison [Integer]
ns
  tensorShape'' WHNFData
_ = WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData)
-> (Seq EgisonValue -> WHNFData) -> Seq EgisonValue -> m WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EgisonValue -> WHNFData
Value (EgisonValue -> WHNFData)
-> (Seq EgisonValue -> EgisonValue) -> Seq EgisonValue -> WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EgisonValue -> EgisonValue
Collection (Seq EgisonValue -> m WHNFData) -> Seq EgisonValue -> m WHNFData
forall a b. (a -> b) -> a -> b
$ [EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList []

tensorToList' :: String -> LazyPrimitiveFunc
tensorToList' :: String -> LazyPrimitiveFunc
tensorToList' = (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc
lazyOneArg WHNFData -> EvalM WHNFData
tensorToList''
 where
  tensorToList'' :: WHNFData -> EvalM WHNFData
tensorToList'' (Value (TensorData (Tensor [Integer]
_ Vector EgisonValue
xs [Index EgisonValue]
_))) =
    WHNFData -> EvalM WHNFData
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> EvalM WHNFData)
-> ([EgisonValue] -> WHNFData) -> [EgisonValue] -> EvalM WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EgisonValue -> WHNFData
Value (EgisonValue -> WHNFData)
-> ([EgisonValue] -> EgisonValue) -> [EgisonValue] -> WHNFData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EgisonValue -> EgisonValue
Collection (Seq EgisonValue -> EgisonValue)
-> ([EgisonValue] -> Seq EgisonValue)
-> [EgisonValue]
-> EgisonValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ([EgisonValue] -> EvalM WHNFData)
-> [EgisonValue] -> EvalM WHNFData
forall a b. (a -> b) -> a -> b
$ Vector EgisonValue -> [EgisonValue]
forall a. Vector a -> [a]
V.toList Vector EgisonValue
xs
  tensorToList'' (ITensor (Tensor [Integer]
_ Vector (IORef Object)
xs [Index EgisonValue]
_)) = do
    IORef (Seq Inner)
inners <- IO (IORef (Seq Inner))
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IORef (Seq Inner))
forall a. IO a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Seq Inner))
 -> StateT
      EvalState (ExceptT EgisonError RuntimeM) (IORef (Seq Inner)))
-> (Seq Inner -> IO (IORef (Seq Inner)))
-> Seq Inner
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IORef (Seq Inner))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Inner -> IO (IORef (Seq Inner))
forall a. a -> IO (IORef a)
newIORef (Seq Inner
 -> StateT
      EvalState (ExceptT EgisonError RuntimeM) (IORef (Seq Inner)))
-> Seq Inner
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IORef (Seq Inner))
forall a b. (a -> b) -> a -> b
$ [Inner] -> Seq Inner
forall a. [a] -> Seq a
Sq.fromList ((IORef Object -> Inner) -> [IORef Object] -> [Inner]
forall a b. (a -> b) -> [a] -> [b]
map IORef Object -> Inner
IElement (Vector (IORef Object) -> [IORef Object]
forall a. Vector a -> [a]
V.toList Vector (IORef Object)
xs))
    WHNFData -> EvalM WHNFData
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef (Seq Inner) -> WHNFData
ICollection IORef (Seq Inner)
inners)
  tensorToList'' WHNFData
x = LazyPrimitiveFunc
makeICollection [WHNFData
x]

dfOrder' :: String -> LazyPrimitiveFunc
dfOrder' :: String -> LazyPrimitiveFunc
dfOrder' = (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc
lazyOneArg WHNFData -> EvalM WHNFData
forall {m :: * -> *}. Monad m => WHNFData -> m WHNFData
dfOrder''
 where
  dfOrder'' :: WHNFData -> m WHNFData
dfOrder'' (Value (TensorData (Tensor [Integer]
ns Vector EgisonValue
_ [Index EgisonValue]
is))) =
    WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData) -> WHNFData -> m WHNFData
forall a b. (a -> b) -> a -> b
$ EgisonValue -> WHNFData
Value (Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
ns Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Index EgisonValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index EgisonValue]
is) :: Integer))
  dfOrder'' (ITensor (Tensor [Integer]
ns Vector (IORef Object)
_ [Index EgisonValue]
is)) =
    WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData) -> WHNFData -> m WHNFData
forall a b. (a -> b) -> a -> b
$ EgisonValue -> WHNFData
Value (Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
ns Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Index EgisonValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index EgisonValue]
is) :: Integer))
  dfOrder'' WHNFData
_ = WHNFData -> m WHNFData
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WHNFData -> m WHNFData) -> WHNFData -> m WHNFData
forall a b. (a -> b) -> a -> b
$ EgisonValue -> WHNFData
Value (Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Integer
0 :: Integer))

addSubscript :: String -> PrimitiveFunc
addSubscript :: String -> PrimitiveFunc
addSubscript = (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String -> PrimitiveFunc
twoArgs ((EgisonValue -> EgisonValue -> EvalM EgisonValue)
 -> String -> PrimitiveFunc)
-> (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String
-> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
fn EgisonValue
sub ->
  case (EgisonValue
fn, EgisonValue
sub) of
    (ScalarData (SingleSymbol (Symbol String
id String
name [Index ScalarData]
is)), ScalarData s :: ScalarData
s@(SingleSymbol (Symbol String
_ String
_ []))) ->
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EgisonValue
ScalarData (SymbolExpr -> ScalarData
SingleSymbol (String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name ([Index ScalarData]
is [Index ScalarData] -> [Index ScalarData] -> [Index ScalarData]
forall a. [a] -> [a] -> [a]
++ [ScalarData -> Index ScalarData
forall a. a -> Index a
Sub ScalarData
s]))))
    (ScalarData (SingleSymbol (Symbol String
id String
name [Index ScalarData]
is)), ScalarData s :: ScalarData
s@(SingleTerm Integer
_ [])) ->
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EgisonValue
ScalarData (SymbolExpr -> ScalarData
SingleSymbol (String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name ([Index ScalarData]
is [Index ScalarData] -> [Index ScalarData] -> [Index ScalarData]
forall a. [a] -> [a] -> [a]
++ [ScalarData -> Index ScalarData
forall a. a -> Index a
Sub ScalarData
s]))))
    (EgisonValue, EgisonValue)
_ -> (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"symbol or integer" (EgisonValue -> WHNFData
Value EgisonValue
fn))

addSuperscript :: String -> PrimitiveFunc
addSuperscript :: String -> PrimitiveFunc
addSuperscript = (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String -> PrimitiveFunc
twoArgs ((EgisonValue -> EgisonValue -> EvalM EgisonValue)
 -> String -> PrimitiveFunc)
-> (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String
-> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
fn EgisonValue
sub ->
  case (EgisonValue
fn, EgisonValue
sub) of
    (ScalarData (SingleSymbol (Symbol String
id String
name [Index ScalarData]
is)), ScalarData s :: ScalarData
s@(SingleSymbol (Symbol String
_ String
_ []))) ->
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EgisonValue
ScalarData (SymbolExpr -> ScalarData
SingleSymbol (String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name ([Index ScalarData]
is [Index ScalarData] -> [Index ScalarData] -> [Index ScalarData]
forall a. [a] -> [a] -> [a]
++ [ScalarData -> Index ScalarData
forall a. a -> Index a
Sup ScalarData
s]))))
    (ScalarData (SingleSymbol (Symbol String
id String
name [Index ScalarData]
is)), ScalarData s :: ScalarData
s@(SingleTerm Integer
_ [])) ->
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EgisonValue
ScalarData (SymbolExpr -> ScalarData
SingleSymbol (String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name ([Index ScalarData]
is [Index ScalarData] -> [Index ScalarData] -> [Index ScalarData]
forall a. [a] -> [a] -> [a]
++ [ScalarData -> Index ScalarData
forall a. a -> Index a
Sup ScalarData
s]))))
    (EgisonValue, EgisonValue)
_ -> (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"symbol" (EgisonValue -> WHNFData
Value EgisonValue
fn))

updateFunctionArgs :: String -> PrimitiveFunc
updateFunctionArgs :: String -> PrimitiveFunc
updateFunctionArgs = (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String -> PrimitiveFunc
twoArgs' ((EgisonValue -> EgisonValue -> EvalM EgisonValue)
 -> String -> PrimitiveFunc)
-> (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String
-> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
funcVal EgisonValue
newArgsColl ->
  case (EgisonValue
funcVal, EgisonValue
newArgsColl) of
    (ScalarData (SingleTerm Integer
1 [(FunctionData ScalarData
name [ScalarData]
_, Integer
1)]), Collection Seq EgisonValue
argsSeq) -> do
      [ScalarData]
args' <- (EgisonValue
 -> StateT EvalState (ExceptT EgisonError RuntimeM) ScalarData)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [ScalarData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) ScalarData
extractScalar (Seq EgisonValue -> [EgisonValue]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
argsSeq)
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EgisonValue -> EvalM EgisonValue)
-> EgisonValue -> EvalM EgisonValue
forall a b. (a -> b) -> a -> b
$ ScalarData -> EgisonValue
ScalarData (Integer -> [(SymbolExpr, Integer)] -> ScalarData
SingleTerm Integer
1 [(ScalarData -> [ScalarData] -> SymbolExpr
FunctionData ScalarData
name [ScalarData]
args', Integer
1)])
    (EgisonValue, EgisonValue)
_ -> (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"function value and collection of scalars" (EgisonValue -> WHNFData
Value EgisonValue
funcVal))
 where
  extractScalar :: EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) ScalarData
extractScalar (ScalarData ScalarData
s) = ScalarData
-> StateT EvalState (ExceptT EgisonError RuntimeM) ScalarData
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ScalarData
s
  extractScalar EgisonValue
val = (CallStack -> EgisonError)
-> StateT EvalState (ExceptT EgisonError RuntimeM) ScalarData
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"scalar" (EgisonValue -> WHNFData
Value EgisonValue
val))

assert ::  String -> PrimitiveFunc
assert :: String -> PrimitiveFunc
assert = (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String -> PrimitiveFunc
twoArgs' ((EgisonValue -> EgisonValue -> EvalM EgisonValue)
 -> String -> PrimitiveFunc)
-> (EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String
-> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
label EgisonValue
test -> do
  Bool
test <- EgisonValue -> EvalM Bool
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
test
  if Bool
test
    then EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EgisonValue -> EvalM EgisonValue)
-> EgisonValue -> EvalM EgisonValue
forall a b. (a -> b) -> a -> b
$ Bool -> EgisonValue
Bool Bool
True
    else (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> CallStack -> EgisonError
Assertion (EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
label))

assertEqual :: String -> PrimitiveFunc
assertEqual :: String -> PrimitiveFunc
assertEqual = (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String -> PrimitiveFunc
threeArgs' ((EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue)
 -> String -> PrimitiveFunc)
-> (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue)
-> String
-> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
label EgisonValue
actual EgisonValue
expected ->
  if EgisonValue
actual EgisonValue -> EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== EgisonValue
expected
     then EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return EgisonValue
actual
     else (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> CallStack -> EgisonError
Assertion
            (EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n but found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
actual))

-- | Sort a list of lists of integers and return the sign of the permutation
-- Each sublist is treated as a unit and sorted lexicographically
-- Used for antisymmetric tensor indices
sortWithSign :: String -> PrimitiveFunc
sortWithSign :: String -> PrimitiveFunc
sortWithSign = (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc
oneArg' ((EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc)
-> (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc
forall a b. (a -> b) -> a -> b
$ \EgisonValue
val -> do
  case EgisonValue
val of
    Collection Seq EgisonValue
xss -> do
      -- Extract list of lists
      let xss' :: [EgisonValue]
xss' = Seq EgisonValue -> [EgisonValue]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
xss
      [[Integer]]
xs <- (EgisonValue
 -> StateT EvalState (ExceptT EgisonError RuntimeM) [Integer])
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [[Integer]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Integer]
extractIntList [EgisonValue]
xss'
      -- Sort lists lexicographically and calculate permutation sign
      let (Integer
sign, [[Integer]]
sortedLists) = [[Integer]] -> (Integer, [[Integer]])
sortWithPermSign [[Integer]]
xs
      let flatList :: [Integer]
flatList = [[Integer]] -> [Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Integer]]
sortedLists
      EgisonValue -> EvalM EgisonValue
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EgisonValue -> EvalM EgisonValue)
-> EgisonValue -> EvalM EgisonValue
forall a b. (a -> b) -> a -> b
$ [EgisonValue] -> EgisonValue
Tuple [Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
sign, Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((Integer -> EgisonValue) -> [Integer] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison [Integer]
flatList))]
    EgisonValue
_ -> (CallStack -> EgisonError) -> EvalM EgisonValue
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"collection of collections" (EgisonValue -> WHNFData
Value EgisonValue
val))
 where
  -- Extract integers from a collection
  extractIntList :: EgisonValue -> EvalM [Integer]
  extractIntList :: EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Integer]
extractIntList (Collection Seq EgisonValue
xs) = (EgisonValue
 -> StateT EvalState (ExceptT EgisonError RuntimeM) Integer)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
extractInt (Seq EgisonValue -> [EgisonValue]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
xs)
  extractIntList EgisonValue
x = (Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
:[]) (Integer -> [Integer])
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
extractInt EgisonValue
x
  
  extractInt :: EgisonValue -> EvalM Integer
  extractInt :: EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
extractInt (ScalarData ScalarData
s) = EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison (ScalarData -> EgisonValue
ScalarData ScalarData
s)
  extractInt EgisonValue
val = (CallStack -> EgisonError)
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"integer" (EgisonValue -> WHNFData
Value EgisonValue
val))
  
  -- Sort lists lexicographically and calculate permutation sign using bubble sort
  sortWithPermSign :: [[Integer]] -> (Integer, [[Integer]])
  sortWithPermSign :: [[Integer]] -> (Integer, [[Integer]])
sortWithPermSign [] = (Integer
1, [])
  sortWithPermSign [[Integer]
x] = (Integer
1, [[Integer]
x])
  sortWithPermSign [[Integer]
x, [Integer]
y] =
    if [Integer]
x [Integer] -> [Integer] -> Bool
forall a. Ord a => a -> a -> Bool
> [Integer]
y then (-Integer
1, [[Integer]
y, [Integer]
x]) else (Integer
1, [[Integer]
x, [Integer]
y])
  sortWithPermSign [[Integer]]
xs =
    let sorted :: [[Integer]]
sorted = [[Integer]] -> [[Integer]]
bubbleSort [[Integer]]
xs
        swaps :: Int
swaps = [[Integer]] -> [[Integer]] -> Int
forall a. Eq a => [a] -> [a] -> Int
countInversions [[Integer]]
xs [[Integer]]
sorted
        sign :: Integer
sign = if Int -> Bool
forall a. Integral a => a -> Bool
even Int
swaps then Integer
1 else -Integer
1
    in (Integer
sign, [[Integer]]
sorted)
  
  -- Bubble sort for lists (lexicographic comparison)
  bubbleSort :: [[Integer]] -> [[Integer]]
  bubbleSort :: [[Integer]] -> [[Integer]]
bubbleSort [] = []
  bubbleSort [[Integer]]
xs =
    let ([[Integer]]
xs', Bool
changed) = [[Integer]] -> ([[Integer]], Bool)
bubblePass [[Integer]]
xs
    in if Bool
changed then [[Integer]] -> [[Integer]]
bubbleSort [[Integer]]
xs' else [[Integer]]
xs'
  
  bubblePass :: [[Integer]] -> ([[Integer]], Bool)
  bubblePass :: [[Integer]] -> ([[Integer]], Bool)
bubblePass [] = ([], Bool
False)
  bubblePass [[Integer]
x] = ([[Integer]
x], Bool
False)
  bubblePass ([Integer]
x:[Integer]
y:[[Integer]]
rest) =
    if [Integer]
x [Integer] -> [Integer] -> Bool
forall a. Ord a => a -> a -> Bool
> [Integer]
y
      then let ([[Integer]]
rest', Bool
_) = [[Integer]] -> ([[Integer]], Bool)
bubblePass ([Integer]
x[Integer] -> [[Integer]] -> [[Integer]]
forall a. a -> [a] -> [a]
:[[Integer]]
rest)
           in ([Integer]
y[Integer] -> [[Integer]] -> [[Integer]]
forall a. a -> [a] -> [a]
:[[Integer]]
rest', Bool
True)
      else let ([[Integer]]
rest', Bool
changed) = [[Integer]] -> ([[Integer]], Bool)
bubblePass ([Integer]
y[Integer] -> [[Integer]] -> [[Integer]]
forall a. a -> [a] -> [a]
:[[Integer]]
rest)
           in ([Integer]
x[Integer] -> [[Integer]] -> [[Integer]]
forall a. a -> [a] -> [a]
:[[Integer]]
rest', Bool
changed)
  
  -- Count inversions between original and sorted list
  countInversions :: (Eq a) => [a] -> [a] -> Int
  countInversions :: forall a. Eq a => [a] -> [a] -> Int
countInversions [a]
orig [a]
sorted =
    let indices :: [Int]
indices = (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> a -> [a] -> Int
forall {a} {b}. (Eq a, Num b, Enum b) => a -> [a] -> b
findIndex a
x [a]
sorted) [a]
orig
        findIndex :: a -> [a] -> b
findIndex a
x [a]
xs = case a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x ([a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [b
0..]) of
          Just b
i -> b
i
          Maybe b
Nothing -> b
0
    in [Int] -> Int
countInv [Int]
indices
  
  countInv :: [Int] -> Int
  countInv :: [Int] -> Int
countInv [] = Int
0
  countInv (Int
x:[Int]
xs) = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x) [Int]
xs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
countInv [Int]
xs

 {-- -- for 'egison-sqlite'
sqlite :: PrimitiveFunc
sqlite  = twoArgs' $ \val val' -> do
  dbName <- fromEgison val
  qStr <- fromEgison val'
  ret <- liftIO $ query' (T.pack dbName) $ T.pack qStr
  return $ makeIO $ return $ Collection $ Sq.fromList $ map (\r -> Tuple (map toEgison r)) ret
 where
  query' :: T.Text -> T.Text -> IO [[String]]
  query' dbName q = do
    db <- SQLite.open dbName
    rowsRef <- newIORef []
    SQLite.execWithCallback db q (\_ _ mcs -> do
                                    row <- forM mcs (\mcol -> case mcol of
                                                              Just col ->  return $ T.unpack col
                                                              Nothing -> return "null")
                                    rows <- readIORef rowsRef
                                    writeIORef rowsRef (row:rows))
    SQLite.close db
    ret <- readIORef rowsRef
    return $ reverse ret
 --} -- for 'egison-sqlite'