--  --                                                          ; {{{1
--
--  File        : Koneko/Eval.hs
--  Maintainer  : Felix C. Stegerman <flx@obfusk.net>
--  Date        : 2022-02-12
--
--  Copyright   : Copyright (C) 2022  Felix C. Stegerman
--  Version     : v0.0.1
--  License     : GPLv3+
--
--  --                                                          ; }}}1

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

                                                              --  {{{1
-- |
--
-- >>> :set -XOverloadedStrings
-- >>> import Data.Maybe
-- >>> id = fromJust . ident
-- >>> ctx <- initContext
-- >>> ev x = eval x ctx []
--
-- >>> ev [str "Hello, World!", KIdent $ id "say!"]
-- Hello, World!
-- []
-- >>> ev [int 1, int 2, KIdent $ id "-"]
-- [-1]
--
-- >>> ev x = evalText "" x ctx []
--
-- >>> ev "\"Hello, World!\" say!"
-- Hello, World!
-- []
-- >>> ev "1 2 +"
-- [3]
--
-- ... TODO ...
--

                                                              --  }}}1

module Koneko.Eval (
  tryK, eval, evalText, evalStdin, evalFile, initContext
) where

import Control.DeepSeq (($!!))
import Control.Exception (throwIO, try)
import Control.Monad (unless, when)
import Data.Bool (bool)
import Data.Char (ord)
import Data.List hiding (lookup)
import Data.List.Split (wordsBy)
import Data.Text (Text)
import Prelude hiding (lookup)
import Safe (atMay)
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)

#if !MIN_VERSION_GLASGOW_HASKELL(8, 8, 1, 0)
import Data.Monoid((<>))
#endif

import qualified Data.HashMap.Strict as H
import qualified Data.HashTable.IO as HT
import qualified Data.Text as T
import qualified Data.Text.IO as T

import Koneko.Data hiding (bool)
import Koneko.Misc (firstJust)
import Paths_koneko (getDataFileName)

import qualified Koneko.Read as R

import qualified Koneko.Bltn as Bltn
import qualified Koneko.IO   as K_IO
import qualified Koneko.JSON as JSON
import qualified Koneko.Math as Math
import qualified Koneko.Prim as Prim
import qualified Koneko.Prld as Prld

tryK :: IO a -> IO (Either KException a)
tryK :: IO a -> IO (Either KException a)
tryK = IO a -> IO (Either KException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

-- eval --

eval, evl :: [KValue] -> Evaluator

eval :: [KValue] -> Evaluator
eval [KValue]
xs Context
c [KValue]
s = ([KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. NFData a => (a -> b) -> a -> b
$!!) ([KValue] -> IO [KValue]) -> IO [KValue] -> IO [KValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [KValue] -> Evaluator
evl [KValue]
xs Context
c [KValue]
s

evl :: [KValue] -> Evaluator
evl    []  Context
_ [KValue]
s  = [KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return [KValue]
s
evl (KValue
x:[KValue]
xt) Context
c [KValue]
s0 = do
  ([KValue]
s1, Bool
deferredCall) <- KValue -> Context -> [KValue] -> IO ([KValue], Bool)
eval1 KValue
x Context
c [KValue]
s0
  let f :: IO [KValue]
f = if Bool
deferredCall then Evaluator
call Context
c [KValue]
s1 else [KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return [KValue]
s1
  if [KValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KValue]
xt then IO [KValue]
f else IO [KValue]
f IO [KValue] -> ([KValue] -> IO [KValue]) -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [KValue] -> Evaluator
evl [KValue]
xt Context
c   -- tail call!

evalText :: FilePath -> Text -> Evaluator
evalText :: FilePath -> Text -> Evaluator
evalText FilePath
name Text
code = [KValue] -> Evaluator
eval ([KValue] -> Evaluator) -> [KValue] -> Evaluator
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> [KValue]
R.read' FilePath
name Text
code

evalStdin :: Context -> Stack -> IO ()
evalStdin :: Context -> [KValue] -> IO ()
evalStdin Context
c [KValue]
s = () () -> IO [KValue] -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
  Text
code <- IO Text
T.getContents; FilePath -> Text -> Evaluator
evalText FilePath
"(stdin)" Text
code Context
c [KValue]
s

evalFile :: FilePath -> Evaluator
evalFile :: FilePath -> Evaluator
evalFile FilePath
f Context
c [KValue]
s = do Text
code <- FilePath -> IO Text
T.readFile FilePath
f; FilePath -> Text -> Evaluator
evalText FilePath
f Text
code Context
c [KValue]
s

eval1, eval1_ :: KValue -> Context -> Stack -> IO (Stack, Bool)

eval1 :: KValue -> Context -> [KValue] -> IO ([KValue], Bool)
eval1 KValue
x Context
c [KValue]
s = do
  Context -> IO () -> IO ()
debug Context
c (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"==> eval " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ KValue -> FilePath
forall a. Show a => a -> FilePath
show KValue
x
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"--> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " ((KValue -> FilePath) -> [KValue] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map KValue -> FilePath
forall a. Show a => a -> FilePath
show ([KValue] -> [FilePath]) -> [KValue] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [KValue] -> [KValue]
forall a. [a] -> [a]
reverse [KValue]
s)
  r :: ([KValue], Bool)
r@([KValue]
s', Bool
_) <- KValue -> Context -> [KValue] -> IO ([KValue], Bool)
eval1_ KValue
x Context
c ([KValue] -> IO ([KValue], Bool))
-> [KValue] -> IO ([KValue], Bool)
forall a b. NFData a => (a -> b) -> a -> b
$!! [KValue]
s
  Context -> IO () -> IO ()
debug Context
c (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"<-- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " ((KValue -> FilePath) -> [KValue] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map KValue -> FilePath
forall a. Show a => a -> FilePath
show ([KValue] -> [FilePath]) -> [KValue] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [KValue] -> [KValue]
forall a. [a] -> [a]
reverse [KValue]
s')
  ([KValue], Bool) -> IO ([KValue], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (([KValue], Bool) -> IO ([KValue], Bool))
-> ([KValue], Bool) -> IO ([KValue], Bool)
forall a b. NFData a => (a -> b) -> a -> b
$!! ([KValue], Bool)
r

eval1_ :: KValue -> Context -> [KValue] -> IO ([KValue], Bool)
eval1_ KValue
x Context
c [KValue]
s = case KValue
x of
  KPrim KPrim
_         -> (,Bool
False) ([KValue] -> ([KValue], Bool))
-> IO [KValue] -> IO ([KValue], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s KValue
x
  KList (List [KValue]
l)  -> (,Bool
False) ([KValue] -> ([KValue], Bool))
-> IO [KValue] -> IO ([KValue], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KValue] -> Evaluator
evalList [KValue]
l Context
c [KValue]
s
  KIdent Ident
i        -> (,Bool
True ) ([KValue] -> ([KValue], Bool))
-> IO [KValue] -> IO ([KValue], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Evaluator
pushIdent (Ident -> Text
unIdent Ident
i) Context
c [KValue]
s
  KQuot Ident
i         -> (,Bool
False) ([KValue] -> ([KValue], Bool))
-> IO [KValue] -> IO ([KValue], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Evaluator
pushIdent (Ident -> Text
unIdent Ident
i) Context
c [KValue]
s
  KBlock Block
b        -> (,Bool
False) ([KValue] -> ([KValue], Bool))
-> IO [KValue] -> IO ([KValue], Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block -> Evaluator
evalBlock Block
b Context
c [KValue]
s
  KValue
_               -> KException -> IO ([KValue], Bool)
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ([KValue], Bool))
-> KException -> IO ([KValue], Bool)
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
EvalUnexpected (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ KValue -> FilePath
forall a. IsString a => KValue -> a
typeAsStr KValue
x

-- TODO
evalList :: [KValue] -> Evaluator
evalList :: [KValue] -> Evaluator
evalList [KValue]
xs Context
c [KValue]
s = do [KValue]
ys <- [KValue] -> Evaluator
evl [KValue]
xs Context
c [KValue]
emptyStack; [KValue] -> [KValue] -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [KValue] -> [KValue]
forall a. [a] -> [a]
reverse [KValue]
ys

-- TODO
pushIdent :: Text -> Evaluator
pushIdent :: Text -> Evaluator
pushIdent Text
i Context
c [KValue]
s = Context -> Text -> IO (Maybe KValue)
lookup Context
c Text
i IO (Maybe KValue) -> (Maybe KValue -> IO [KValue]) -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [KValue]
-> (KValue -> IO [KValue]) -> Maybe KValue -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [KValue]
forall a. IO a
err ([KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return ([KValue] -> IO [KValue])
-> (KValue -> [KValue]) -> KValue -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> KValue -> [KValue]
forall a. ToVal a => [KValue] -> a -> [KValue]
push [KValue]
s)
  where
    err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
NameError (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
i

evalBlock :: Block -> Evaluator
evalBlock :: Block -> Evaluator
evalBlock Block
b Context
c [KValue]
s = [KValue] -> Block -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s Block
b { blkScope :: Maybe Scope
blkScope = Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c }

-- call --

call :: Evaluator
call :: Evaluator
call Context
c [KValue]
s = do
  Context -> IO () -> IO ()
debug Context
c (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"*** call ***"
  (KValue
x, [KValue]
s') <- [KValue] -> IO (KValue, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  case KValue
x of
    KPrim (KStr Text
y)  -> Text -> Evaluator
callStr      Text
y Context
c [KValue]
s'
    KPair Pair
p         -> Pair -> Evaluator
callPair     Pair
p Context
c [KValue]
s'
    KList List
l         -> List -> Evaluator
callList     List
l Context
c [KValue]
s'
    KDict Dict
d         -> Dict -> Evaluator
callDict     Dict
d Context
c [KValue]
s'
    KBlock Block
b        -> Block -> Evaluator
callBlock    Block
b Context
c [KValue]
s'
    KBuiltin Builtin
b      -> Builtin -> Evaluator
biRun        Builtin
b Context
c [KValue]
s'
    KMulti Multi
m        -> Multi -> Evaluator
callMulti    Multi
m Context
c [KValue]
s'
    KRecordT RecordT
r      -> RecordT -> Evaluator
callRecordT  RecordT
r Context
c [KValue]
s'
    KRecord Record
r       -> Record -> Evaluator
callRecord   Record
r Context
c [KValue]
s'
    KThunk Thunk
t        -> Thunk -> Evaluator
callThunk    Thunk
t Context
c [KValue]
s'
    KValue
_               -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
UncallableType (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ KValue -> FilePath
forall a. IsString a => KValue -> a
typeAsStr KValue
x

-- TODO
callStr :: Text -> Evaluator
callStr :: Text -> Evaluator
callStr Text
x Context
_ [KValue]
s = do
  (Kwd Text
op, [KValue]
s') <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  let o :: Text
o = Text
"str." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op; p :: a -> IO [KValue]
p = [KValue] -> a -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s'; pr :: Evaluator -> IO [KValue]
pr = Builtin -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Builtin -> IO [KValue])
-> (Evaluator -> Builtin) -> Evaluator -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Evaluator -> Builtin
mkOp Text
o
  case Text
op of
    Text
"ord"     ->  do  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Int
T.length Text
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ Either FilePath KValue -> FilePath -> KException
stackExpected
                        (FilePath -> Either FilePath KValue
forall a b. a -> Either a b
Left (FilePath -> Either FilePath KValue)
-> FilePath -> Either FilePath KValue
forall a b. (a -> b) -> a -> b
$ FilePath
"str of length " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Text -> Int
T.length Text
x))
                        FilePath
"str of length 1"
                      Integer -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Integer -> IO [KValue]) -> Integer -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
x
    Text
"lower"   ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
x
    Text
"upper"   ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toUpper Text
x
    Text
"reverse" ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse Text
x
    Text
"trim"    ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
x
    Text
"triml"   ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripStart Text
x
    Text
"trimr"   ->  Text -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripEnd Text
x
    Text
"starts-with?"
              ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Text -> Text -> Bool
`T.isPrefixOf` Text
x)
    Text
"ends-with?"
              ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Text -> Text -> Bool
`T.isSuffixOf` Text
x)
    Text
"->list"  ->  KValue -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (KValue -> IO [KValue]) -> KValue -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [Text] -> KValue
forall a. ToVal a => [a] -> KValue
list ([Text] -> KValue) -> [Text] -> KValue
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> FilePath -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton (FilePath -> [Text]) -> FilePath -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
x
    Text
"append"  ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x)
    Text
"slice"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    ((KValue
i, KValue
j, Integer
step), [KValue]
s2) <- [KValue] -> IO ((KValue, KValue, Integer), [KValue])
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
[KValue] -> IO ((a, b, c), [KValue])
pop3' [KValue]
s1; let lx :: Integer
lx = Text -> Integer
lengthT Text
x
                    Integer
i' <- KValue -> Integer -> IO Integer
forall a. FromVal a => KValue -> a -> IO a
nilToDef KValue
i Integer
0; Integer
j' <- KValue -> Integer -> IO Integer
forall a. FromVal a => KValue -> a -> IO a
nilToDef KValue
j Integer
lx
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
step Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
NotImplemented
                      (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": step other than 1"
                    [KValue] -> Text -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2 (Text -> IO [KValue]) -> Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Int -> Text -> Text)
-> (Int -> Text -> Text)
-> Integer
-> Integer
-> Integer
-> Integer
-> Text
-> Text
forall a b.
Num a =>
(a -> b -> b)
-> (a -> b -> b)
-> Integer
-> Integer
-> Integer
-> Integer
-> b
-> b
slice Int -> Text -> Text
T.take Int -> Text -> Text
T.drop Integer
i' Integer
j' Integer
step Integer
lx Text
x
    Text
"empty?"  ->  Bool -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Bool -> IO [KValue]) -> Bool -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
x
    Text
"len"     ->  Integer -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Integer -> IO [KValue]) -> Integer -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Integer
lengthT Text
x
    Text
"get^"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Integer
i, [KValue]
s2) <- [KValue] -> IO (Integer, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1
                    let err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
IndexError (Text -> FilePath
T.unpack Text
o) (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
i
                    IO [KValue] -> (Text -> IO [KValue]) -> Maybe Text -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [KValue]
forall a. IO a
err ([KValue] -> Text -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2) (Maybe Text -> IO [KValue]) -> Maybe Text -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> Integer -> Maybe Text
indexT Text
x Integer
i
    Text
"has?"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Integer -> Bool) -> Evaluator) -> (Integer -> Bool) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Text -> Integer) -> Text -> Integer -> Bool
forall a. (a -> Integer) -> a -> Integer -> Bool
has Text -> Integer
lengthT Text
x
    Text
"elem?"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Text -> Text -> Bool
`T.isInfixOf` Text
x)
    Text
"index"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Integer) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Text -> Text -> Maybe Integer
`indexOf` Text
x)
    Text
_         ->  KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnknownField (Text -> FilePath
T.unpack Text
op) FilePath
"str"

callPair :: Pair -> Evaluator
callPair :: Pair -> Evaluator
callPair Pair{KValue
Kwd
value :: Pair -> KValue
key :: Pair -> Kwd
value :: KValue
key :: Kwd
..} Context
_ [KValue]
s = do
  (Kwd Text
op, [KValue]
s') <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  case Text
op of
    Text
"key"   -> [KValue] -> Kwd -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s' Kwd
key
    Text
"value" -> [KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s' KValue
value
    Text
_       -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnknownField (Text -> FilePath
T.unpack Text
op) FilePath
"pair"

-- TODO
callList :: List -> Evaluator
callList :: List -> Evaluator
callList (List [KValue]
l) Context
_ [KValue]
s = do
  (Kwd Text
op, [KValue]
s') <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  let o :: Text
o = Text
"list." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op; p :: a -> IO [KValue]
p = [KValue] -> a -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s'; pr :: Evaluator -> IO [KValue]
pr = Builtin -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Builtin -> IO [KValue])
-> (Evaluator -> Builtin) -> Evaluator -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Evaluator -> Builtin
mkOp Text
o
      g :: IO ()
g = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([KValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KValue]
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
EmptyList (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
o
  case Text
op of
    Text
"head^"   ->  IO ()
g IO () -> IO [KValue] -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KValue -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> KValue
forall a. [a] -> a
head [KValue]
l)                             -- safe!
    Text
"tail^"   ->  IO ()
g IO () -> IO [KValue] -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> [KValue]
forall a. [a] -> [a]
tail [KValue]
l)                             -- safe!
    Text
"uncons^" ->  IO ()
g IO () -> IO [KValue] -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [KValue] -> [KValue] -> IO [KValue]
forall a. ToVal a => [KValue] -> [a] -> IO [KValue]
rpush [KValue]
s' [[KValue] -> KValue
forall a. [a] -> a
head [KValue]
l, [KValue] -> KValue
forall a. ToVal a => [a] -> KValue
list ([KValue] -> KValue) -> [KValue] -> KValue
forall a b. (a -> b) -> a -> b
$ [KValue] -> [KValue]
forall a. [a] -> [a]
tail [KValue]
l]       -- safe!
    Text
"cons"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (KValue -> [KValue]) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (KValue -> [KValue] -> [KValue]
forall a. a -> [a] -> [a]
:[KValue]
l)
    Text
"sort"    ->  [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [KValue] -> [KValue]
forall a. Ord a => [a] -> [a]
sort [KValue]
l
    Text
"sort'"   ->  [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> Ordering) -> [KValue] -> [KValue]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp [KValue]
l
    Text
"append"  ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ ([KValue] -> [KValue]) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ([KValue] -> [KValue] -> [KValue]
forall a. [a] -> [a] -> [a]
++ [KValue]
l)
    Text
"slice"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    ((KValue
i, KValue
j, Integer
step), [KValue]
s2) <- [KValue] -> IO ((KValue, KValue, Integer), [KValue])
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
[KValue] -> IO ((a, b, c), [KValue])
pop3' [KValue]
s1; let ll :: Integer
ll = [KValue] -> Integer
forall a. [a] -> Integer
len [KValue]
l
                    Integer
i' <- KValue -> Integer -> IO Integer
forall a. FromVal a => KValue -> a -> IO a
nilToDef KValue
i Integer
0; Integer
j' <- KValue -> Integer -> IO Integer
forall a. FromVal a => KValue -> a -> IO a
nilToDef KValue
j Integer
ll
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
step Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
NotImplemented
                      (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": step other than 1"
                    [KValue] -> [KValue] -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2 ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Int -> [KValue] -> [KValue])
-> (Int -> [KValue] -> [KValue])
-> Integer
-> Integer
-> Integer
-> Integer
-> [KValue]
-> [KValue]
forall a b.
Num a =>
(a -> b -> b)
-> (a -> b -> b)
-> Integer
-> Integer
-> Integer
-> Integer
-> b
-> b
slice Int -> [KValue] -> [KValue]
forall a. Int -> [a] -> [a]
take Int -> [KValue] -> [KValue]
forall a. Int -> [a] -> [a]
drop Integer
i' Integer
j' Integer
step Integer
ll [KValue]
l
    Text
"empty?"  ->  Bool -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Bool -> IO [KValue]) -> Bool -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [KValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KValue]
l
    Text
"len"     ->  Integer -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Integer -> IO [KValue]) -> Integer -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [KValue] -> Integer
forall a. [a] -> Integer
len [KValue]
l
    Text
"get^"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Integer
i, [KValue]
s2) <- [KValue] -> IO (Integer, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1
                    let err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
IndexError (Text -> FilePath
T.unpack Text
o) (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
i
                    IO [KValue]
-> (KValue -> IO [KValue]) -> Maybe KValue -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [KValue]
forall a. IO a
err ([KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2) (Maybe KValue -> IO [KValue]) -> Maybe KValue -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ [KValue] -> Int -> Maybe KValue
forall a. [a] -> Int -> Maybe a
atMay [KValue]
l (Int -> Maybe KValue) -> Int -> Maybe KValue
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
    Text
"has?"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Integer -> Bool) -> Evaluator) -> (Integer -> Bool) -> Evaluator
forall a b. (a -> b) -> a -> b
$ ([KValue] -> Integer) -> [KValue] -> Integer -> Bool
forall a. (a -> Integer) -> a -> Integer -> Bool
has [KValue] -> Integer
forall a. [a] -> Integer
len [KValue]
l
    Text
"elem?"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (KValue -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (KValue -> [KValue] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KValue]
l)
    Text
_         ->  KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnknownField (Text -> FilePath
T.unpack Text
op) FilePath
"list"

-- TODO
callDict :: Dict -> Evaluator
callDict :: Dict -> Evaluator
callDict (Dict DictTable
h) Context
_ [KValue]
s = do
  (Kwd Text
op, [KValue]
s') <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  let o :: Text
o = Text
"dict." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op; p :: a -> IO [KValue]
p = [KValue] -> a -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s'; pr :: Evaluator -> IO [KValue]
pr = Builtin -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Builtin -> IO [KValue])
-> (Evaluator -> Builtin) -> Evaluator -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Evaluator -> Builtin
mkOp Text
o
  case Text
op of
    Text
"keys"    ->  [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ (Text -> KValue) -> [Text] -> [KValue]
forall a b. (a -> b) -> [a] -> [b]
map Text -> KValue
kwd ([Text] -> [KValue]) -> [Text] -> [KValue]
forall a b. (a -> b) -> a -> b
$ DictTable -> [Text]
forall k v. HashMap k v -> [k]
H.keys DictTable
h
    Text
"values"  ->  [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p ([KValue] -> IO [KValue]) -> [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ DictTable -> [KValue]
forall k v. HashMap k v -> [v]
H.elems DictTable
h
    Text
"pairs"   ->  [KValue] -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p [ Kwd -> KValue -> KValue
forall a. ToVal a => Kwd -> a -> KValue
pair (Text -> Kwd
Kwd Text
k) KValue
v | (Text
k, KValue
v) <- [(Text, KValue)] -> [(Text, KValue)]
forall a. Ord a => [a] -> [a]
sort ([(Text, KValue)] -> [(Text, KValue)])
-> [(Text, KValue)] -> [(Text, KValue)]
forall a b. (a -> b) -> a -> b
$ DictTable -> [(Text, KValue)]
forall k v. HashMap k v -> [(k, v)]
H.toList DictTable
h ]
    Text
"merge"   ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Dict DictTable
h2, [KValue]
s2) <- [KValue] -> IO (Dict, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1
                    [KValue] -> Dict -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2 (Dict -> IO [KValue]) -> Dict -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ DictTable -> Dict
Dict (DictTable -> Dict) -> DictTable -> Dict
forall a b. (a -> b) -> a -> b
$ DictTable -> DictTable -> DictTable
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
H.union DictTable
h DictTable
h2
    Text
"delete"  ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Kwd Text
k, [KValue]
s2) <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1
                    [KValue] -> Dict -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2 (Dict -> IO [KValue]) -> Dict -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ DictTable -> Dict
Dict (DictTable -> Dict) -> DictTable -> Dict
forall a b. (a -> b) -> a -> b
$ Text -> DictTable -> DictTable
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
k DictTable
h
    Text
"empty?"  ->  Bool -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Bool -> IO [KValue]) -> Bool -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ DictTable -> Bool
forall k v. HashMap k v -> Bool
H.null DictTable
h
    Text
"len"     ->  Integer -> IO [KValue]
forall a. ToVal a => a -> IO [KValue]
p (Integer -> IO [KValue]) -> Integer -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DictTable -> Int
forall k v. HashMap k v -> Int
H.size DictTable
h
    Text
"get^"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Kwd Text
k, [KValue]
s2) <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1
                    let err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
KeyError (Text -> FilePath
T.unpack Text
o) (Text -> FilePath
T.unpack Text
k)
                    IO [KValue]
-> (KValue -> IO [KValue]) -> Maybe KValue -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [KValue]
forall a. IO a
err ([KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2) (Maybe KValue -> IO [KValue]) -> Maybe KValue -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> DictTable -> Maybe KValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
k DictTable
h
    Text
"has?"    ->  Evaluator -> IO [KValue]
pr (Evaluator -> IO [KValue]) -> Evaluator -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ \Context
_ [KValue]
s1 -> do
                    (Kwd Text
k, [KValue]
s2) <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s1; [KValue] -> Bool -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s2 (Bool -> IO [KValue]) -> Bool -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> DictTable -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
H.member Text
k DictTable
h
    Text
_         ->  KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnknownField (Text -> FilePath
T.unpack Text
op) FilePath
"dict"

-- TODO
callMulti :: Multi -> Evaluator
callMulti :: Multi -> Evaluator
callMulti Multi{Int
Text
MultiTable
mltTable :: Multi -> MultiTable
mltName :: Multi -> Text
mltArity :: Multi -> Int
mltTable :: MultiTable
mltName :: Text
mltArity :: Int
..} Context
c [KValue]
s = do
    [Text]
sig <- (KValue -> Text) -> [KValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map KValue -> Text
toSig ([KValue] -> [Text])
-> (([KValue], [KValue]) -> [KValue])
-> ([KValue], [KValue])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([KValue], [KValue]) -> [KValue]
forall a b. (a, b) -> a
fst (([KValue], [KValue]) -> [Text])
-> IO ([KValue], [KValue]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [KValue] -> IO ([KValue], [KValue])
forall a. FromVal a => Int -> [KValue] -> IO ([a], [KValue])
popN' Int
mltArity [KValue]
s
    let f :: Block -> IO [KValue]
f Block
b = Block -> Evaluator
callBlock Block
b Context
c [KValue]
s; look :: [Text] -> IO (Maybe Block)
look = MultiTable -> [Text] -> IO (Maybe Block)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup MultiTable
mltTable
    IO [KValue] -> (Block -> IO [KValue]) -> Maybe Block -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> IO [KValue]
forall a. [Text] -> IO a
err [Text]
sig) Block -> IO [KValue]
f (Maybe Block -> IO [KValue]) -> IO (Maybe Block) -> IO [KValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [IO (Maybe Block)] -> IO (Maybe Block)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJust [[Text] -> IO (Maybe Block)
look [Text]
sig, [Text] -> IO (Maybe Block)
look [Text]
forall a. IsString a => [a]
def]
  where
    toSig :: KValue -> Text
toSig (KRecord Record
r) = RecordT -> Text
recordTypeSig (RecordT -> Text) -> RecordT -> Text
forall a b. (a -> b) -> a -> b
$ Record -> RecordT
recType Record
r
    toSig KValue
t           = KValue -> Text
forall a. IsString a => KValue -> a
typeAsStr KValue
t
    def :: [a]
def               = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
mltArity a
"_"
    err :: [Text] -> IO a
err [Text]
sig           = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
MultiMatchFailed (Text -> FilePath
T.unpack Text
mltName)
                      (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ KValue -> FilePath
forall a. Show a => a -> FilePath
show (KValue -> FilePath) -> KValue -> FilePath
forall a b. (a -> b) -> a -> b
$ [KValue] -> KValue
forall a. ToVal a => [a] -> KValue
list ([KValue] -> KValue) -> [KValue] -> KValue
forall a b. (a -> b) -> a -> b
$ (Text -> KValue) -> [Text] -> [KValue]
forall a b. (a -> b) -> [a] -> [b]
map Text -> KValue
kwd [Text]
sig

callRecord :: Record -> Evaluator
callRecord :: Record -> Evaluator
callRecord Record
r Context
_ [KValue]
s = do
    (Kwd Text
k, [KValue]
s') <- [KValue] -> IO (Kwd, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
    let err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnknownField (Text -> FilePath
T.unpack Text
k) (Text -> FilePath
T.unpack Text
recName)
    IO [KValue] -> (Int -> IO [KValue]) -> Maybe Int -> IO [KValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [KValue]
forall a. IO a
err ([KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s' (KValue -> IO [KValue]) -> (Int -> KValue) -> Int -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Record -> [KValue]
recValues Record
r [KValue] -> Int -> KValue
forall a. [a] -> Int -> a
!!)) (Maybe Int -> IO [KValue]) -> Maybe Int -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Text
k [Text]
recFields -- safe!
  where
    RecordT{[Text]
Text
recFields :: RecordT -> [Text]
recName :: RecordT -> Text
recFields :: [Text]
recName :: Text
..} = Record -> RecordT
recType Record
r

callThunk :: Thunk -> Evaluator
callThunk :: Thunk -> Evaluator
callThunk Thunk
t Context
_ [KValue]
s = [KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s (KValue -> IO [KValue]) -> IO KValue -> IO [KValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Thunk -> IO KValue
runThunk Thunk
t

-- apply --

-- TODO
apply :: Evaluator
apply :: Evaluator
apply Context
c [KValue]
s = do
  Context -> IO () -> IO ()
debug Context
c (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"*** apply ***"
  (KValue
x, [KValue]
s') <- [KValue] -> IO (KValue, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  case KValue
x of
    KBlock Block
b    -> Block -> Evaluator
applyBlock Block
b Context
c [KValue]
s'
    KMulti Multi
_    -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
NotImplemented FilePath
"apply multi"
    KRecordT RecordT
r  -> RecordT -> Evaluator
applyRecordT RecordT
r Context
c [KValue]
s'
    KValue
_           -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnapplicableType (KValue -> FilePath
forall a. IsString a => KValue -> a
typeAsStr KValue
x) FilePath
"apply"

-- TODO
apply_dict :: Evaluator
apply_dict :: Evaluator
apply_dict Context
c [KValue]
s = do
  Context -> IO () -> IO ()
debug Context
c (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"*** apply-dict ***"
  (KValue
x, [KValue]
s') <- [KValue] -> IO (KValue, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s
  case KValue
x of
    KBlock Block
b    -> Block -> Evaluator
apply_dictBlock Block
b Context
c [KValue]
s'
    KMulti Multi
_    -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
NotImplemented FilePath
"apply-dict multi"
    KRecordT RecordT
r  -> RecordT -> Evaluator
apply_dictRecordT RecordT
r Context
c [KValue]
s'
    KValue
_           -> KException -> IO [KValue]
forall e a. Exception e => e -> IO a
throwIO (KException -> IO [KValue]) -> KException -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> KException
UnapplicableType (KValue -> FilePath
forall a. IsString a => KValue -> a
typeAsStr KValue
x) FilePath
"apply-dict"

-- call & apply: block --

-- TODO
callBlock :: Block -> Evaluator
callBlock :: Block -> Evaluator
callBlock b :: Block
b@Block{[KValue]
[Ident]
Maybe Scope
blkCode :: Block -> [KValue]
blkParams :: Block -> [Ident]
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkScope :: Block -> Maybe Scope
..} Context
c [KValue]
s0 = do
    ([KValue]
s1, [(Text, KValue)]
args) <- [(Text, KValue)]
-> [KValue] -> [Text] -> IO ([KValue], [(Text, KValue)])
popArgs [] [KValue]
s0 ([Text] -> IO ([KValue], [(Text, KValue)]))
-> [Text] -> IO ([KValue], [(Text, KValue)])
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
nparms'
    Context
sc <- [(Text, KValue)] -> Context -> Block -> IO Context
forkScope ([(Text, KValue)]
args [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++ (Text -> (Text, KValue)) -> [Text] -> [(Text, KValue)]
forall a b. (a -> b) -> [a] -> [b]
map (,KValue
nil) [Text]
sparms [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++ [(Text, KValue)]
forall a. IsString a => [(a, KValue)]
cma) Context
c Block
b
    [KValue] -> Evaluator
evl [KValue]
blkCode Context
sc [KValue]
s1
  where
    ([Text]
sparms, [Text]
nparms)  = [Text] -> ([Text], [Text])
partitionSpecial ([Text] -> ([Text], [Text])) -> [Text] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ (Ident -> Text) -> [Ident] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Text
unIdent [Ident]
blkParams
    nparms' :: [Text]
nparms'           = Text -> [Text] -> [Text]
forall a. Eq a => a -> [a] -> [a]
delete Text
forall p. IsString p => p
cm [Text]
nparms
    cm :: p
cm                = p
"__caller-module__"
    cma :: [(a, KValue)]
cma               = if Text
forall p. IsString p => p
cm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
nparms then
                        [(a
forall p. IsString p => p
cm, Text -> KValue
kwd (Text -> KValue) -> Text -> KValue
forall a b. (a -> b) -> a -> b
$ Scope -> Text
modName (Scope -> Text) -> Scope -> Text
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c)] else []

-- TODO
applyBlock :: Block -> Evaluator
applyBlock :: Block -> Evaluator
applyBlock b :: Block
b@Block{[KValue]
[Ident]
Maybe Scope
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkCode :: Block -> [KValue]
blkParams :: Block -> [Ident]
blkScope :: Block -> Maybe Scope
..} Context
c [KValue]
s0 = do
    ([KValue]
l, [KValue]
s1) <- [KValue] -> IO ([KValue], [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s0; let ll :: Int
ll = [KValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [KValue]
l
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ll Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lnp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
expected (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lnp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" arg(s) for apply"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ll Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lnp Bool -> Bool -> Bool
&& Text
"&" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
sparms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> KException
applyMissing Bool
False
    let ([KValue]
l1, [KValue]
l2)  = Int -> [KValue] -> ([KValue], [KValue])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
lnp [KValue]
l
        args :: [(Text, KValue)]
args      = [Text] -> [KValue] -> [(Text, KValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
nparms [KValue]
l1 [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++ (Text -> (Text, KValue)) -> [Text] -> [(Text, KValue)]
forall a b. (a -> b) -> [a] -> [b]
map (,KValue
nil) [Text]
sparms' [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++ [(Text
"&", [KValue] -> KValue
forall a. ToVal a => [a] -> KValue
list [KValue]
l2)]
    Context
sc <- [(Text, KValue)] -> Context -> Block -> IO Context
forkScope [(Text, KValue)]
args Context
c Block
b
    ([KValue] -> [KValue] -> [KValue]
forall a. [a] -> [a] -> [a]
++ [KValue]
s1) ([KValue] -> [KValue]) -> IO [KValue] -> IO [KValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KValue] -> Evaluator
evl [KValue]
blkCode Context
sc [KValue]
emptyStack
  where
    ([Text]
sparms, [Text]
nparms)  = [Text] -> ([Text], [Text])
partitionSpecial ([Text] -> ([Text], [Text])) -> [Text] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ (Ident -> Text) -> [Ident] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Text
unIdent [Ident]
blkParams
    sparms' :: [Text]
sparms'           = Text -> [Text] -> [Text]
forall a. Eq a => a -> [a] -> [a]
delete Text
"&" [Text]
sparms
    lnp :: Int
lnp               = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
nparms

-- TODO
apply_dictBlock :: Block -> Evaluator
apply_dictBlock :: Block -> Evaluator
apply_dictBlock b :: Block
b@Block{[KValue]
[Ident]
Maybe Scope
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkCode :: Block -> [KValue]
blkParams :: Block -> [Ident]
blkScope :: Block -> Maybe Scope
..} Context
c [KValue]
s0 = do
    (d :: Dict
d@(Dict DictTable
h), [KValue]
s1) <- [KValue] -> IO (Dict, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s0
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"&&" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
sparms) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> KException
applyMissing Bool
True
    [KValue]
vals <- Either KException [KValue] -> IO [KValue]
forall a. Either KException a -> IO a
retOrThrow (Either KException [KValue] -> IO [KValue])
-> Either KException [KValue] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ FilePath -> Dict -> [Text] -> Either KException [KValue]
dictLookup FilePath
"apply-dict" Dict
d [Text]
nparms
    let h' :: DictTable
h'    = (Text -> KValue -> Bool) -> DictTable -> DictTable
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
H.filterWithKey (\Text
k KValue
_ -> Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
nparms) DictTable
h
        args :: [(Text, KValue)]
args  = [Text] -> [KValue] -> [(Text, KValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
nparms [KValue]
vals [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++ (Text -> (Text, KValue)) -> [Text] -> [(Text, KValue)]
forall a b. (a -> b) -> [a] -> [b]
map (,KValue
nil) [Text]
sparms' [(Text, KValue)] -> [(Text, KValue)] -> [(Text, KValue)]
forall a. [a] -> [a] -> [a]
++
                [(Text
"&&", Dict -> KValue
KDict (Dict -> KValue) -> Dict -> KValue
forall a b. (a -> b) -> a -> b
$ DictTable -> Dict
Dict DictTable
h')]
    Context
sc <- [(Text, KValue)] -> Context -> Block -> IO Context
forkScope [(Text, KValue)]
args Context
c Block
b
    ([KValue] -> [KValue] -> [KValue]
forall a. [a] -> [a] -> [a]
++ [KValue]
s1) ([KValue] -> [KValue]) -> IO [KValue] -> IO [KValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KValue] -> Evaluator
evl [KValue]
blkCode Context
sc [KValue]
emptyStack
  where
    ([Text]
sparms, [Text]
nparms)  = [Text] -> ([Text], [Text])
partitionSpecial ([Text] -> ([Text], [Text])) -> [Text] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ (Ident -> Text) -> [Ident] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Text
unIdent [Ident]
blkParams
    sparms' :: [Text]
sparms'           = Text -> [Text] -> [Text]
forall a. Eq a => a -> [a] -> [a]
delete Text
"&&" [Text]
sparms

-- call & apply: record-type --

callRecordT :: RecordT -> Evaluator
callRecordT :: RecordT -> Evaluator
callRecordT t :: RecordT
t@RecordT{[Text]
Text
recFields :: [Text]
recName :: Text
recFields :: RecordT -> [Text]
recName :: RecordT -> Text
..} Context
_ [KValue]
s = do
  ([KValue]
l, [KValue]
s') <- Int -> [KValue] -> IO ([KValue], [KValue])
forall a. FromVal a => Int -> [KValue] -> IO ([a], [KValue])
popN' ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
recFields) [KValue]
s; [KValue] -> Either KException Record -> IO [KValue]
_pushRec [KValue]
s' (Either KException Record -> IO [KValue])
-> Either KException Record -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ RecordT -> [KValue] -> Either KException Record
record RecordT
t [KValue]
l

applyRecordT :: RecordT -> Evaluator
applyRecordT :: RecordT -> Evaluator
applyRecordT RecordT
t Context
_ [KValue]
s = do
  ([KValue]
l, [KValue]
s') <- [KValue] -> IO ([KValue], [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s; [KValue] -> Either KException Record -> IO [KValue]
_pushRec [KValue]
s' (Either KException Record -> IO [KValue])
-> Either KException Record -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ RecordT -> [KValue] -> Either KException Record
record RecordT
t [KValue]
l

apply_dictRecordT :: RecordT -> Evaluator
apply_dictRecordT :: RecordT -> Evaluator
apply_dictRecordT t :: RecordT
t@RecordT{[Text]
Text
recFields :: [Text]
recName :: Text
recFields :: RecordT -> [Text]
recName :: RecordT -> Text
..} Context
_ [KValue]
s = do
  (d :: Dict
d@(Dict DictTable
h), [KValue]
s') <- [KValue] -> IO (Dict, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s; let uf :: [Text]
uf = DictTable -> [Text]
forall k v. HashMap k v -> [k]
H.keys DictTable
h [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
recFields
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
uf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
unexpected (FilePath -> KException) -> FilePath -> KException
forall a b. (a -> b) -> a -> b
$
    FilePath
"key(s) " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " [Text]
uf)
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for record " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
recName
  let l :: Either KException [KValue]
l = FilePath -> Dict -> [Text] -> Either KException [KValue]
dictLookup FilePath
"record-type.apply-dict" Dict
d [Text]
recFields
  [KValue] -> Either KException Record -> IO [KValue]
_pushRec [KValue]
s' (Either KException Record -> IO [KValue])
-> Either KException Record -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ RecordT -> [KValue] -> Either KException Record
record RecordT
t ([KValue] -> Either KException Record)
-> Either KException [KValue] -> Either KException Record
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either KException [KValue]
l

_pushRec :: Stack -> Either KException Record -> IO Stack
_pushRec :: [KValue] -> Either KException Record -> IO [KValue]
_pushRec [KValue]
s Either KException Record
r = Either KException Record -> IO Record
forall a. Either KException a -> IO a
retOrThrow Either KException Record
r IO Record -> (Record -> IO [KValue]) -> IO [KValue]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [KValue] -> KValue -> IO [KValue]
forall a. ToVal a => [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s (KValue -> IO [KValue])
-> (Record -> KValue) -> Record -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record -> KValue
KRecord

-- load module from file --

-- TODO
loadMod :: Context -> Identifier -> IO ()
loadMod :: Context -> Text -> IO ()
loadMod Context
ctx Text
name = () () -> IO [KValue] -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
    FilePath
lib   <- FilePath -> IO FilePath
getDataFileName FilePath
"lib"
    [FilePath]
ps    <- Char -> FilePath -> [FilePath]
forall a. Eq a => a -> [a] -> [[a]]
split Char
':' (FilePath -> [FilePath])
-> (Maybe FilePath -> FilePath) -> Maybe FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" FilePath -> FilePath
forall a. a -> a
id (Maybe FilePath -> [FilePath])
-> IO (Maybe FilePath) -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"KONEKOPATH"
    FilePath
file  <- [FilePath] -> IO FilePath
f ([FilePath] -> IO FilePath) -> [FilePath] -> IO FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
fname) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
libFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
ps
    FilePath -> Evaluator
evalFile FilePath
file Context
ctx [KValue]
emptyStack
  where
    f :: [FilePath] -> IO FilePath
f []      = KException -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO (KException -> IO FilePath) -> KException -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> KException
ModuleLoadError FilePath
n
    f (FilePath
x:[FilePath]
xt)  = FilePath -> IO Bool
doesFileExist FilePath
x IO Bool -> (Bool -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FilePath -> IO FilePath -> Bool -> IO FilePath
forall a. a -> a -> Bool -> a
bool ([FilePath] -> IO FilePath
f [FilePath]
xt) (FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
x)
    fname :: FilePath
fname     = (FilePath -> FilePath -> FilePath) -> [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 FilePath -> FilePath -> FilePath
(</>) (Char -> FilePath -> [FilePath]
forall a. Eq a => a -> [a] -> [[a]]
split Char
'/' FilePath
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".knk"
    split :: a -> [a] -> [[a]]
split a
c   = (a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c); n :: FilePath
n = Text -> FilePath
T.unpack Text
name

-- initial context --

initContext :: IO Context
initContext :: IO Context
initContext = do
  Context
ctx <- IO Context
initMainContext
  let load :: Text -> IO ()
load = Context -> Text -> IO ()
loadMod Context
ctx
  Context
-> (Text -> IO ())
-> Evaluator
-> Evaluator
-> Evaluator
-> (Block -> Evaluator)
-> IO ()
Prim.initCtx Context
ctx Text -> IO ()
load Evaluator
call Evaluator
apply Evaluator
apply_dict Block -> Evaluator
callBlock
  Context -> Evaluator -> IO ()
Bltn.initCtx Context
ctx Evaluator
call
  Context -> (Text -> IO ()) -> IO ()
Prld.initCtx Context
ctx Text -> IO ()
load
  Context -> IO ()
K_IO.initCtx Context
ctx
  Context -> IO ()
JSON.initCtx Context
ctx
  Context -> IO ()
Math.initCtx Context
ctx
  Context -> IO Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
ctx

-- utilities: block call/apply --

popArgs :: Args -> Stack -> [Identifier] -> IO (Stack, Args)
popArgs :: [(Text, KValue)]
-> [KValue] -> [Text] -> IO ([KValue], [(Text, KValue)])
popArgs [(Text, KValue)]
r [KValue]
s []      = ([KValue], [(Text, KValue)]) -> IO ([KValue], [(Text, KValue)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([KValue]
s, [(Text, KValue)]
r)
popArgs [(Text, KValue)]
r [KValue]
s (Text
k:[Text]
kt)  = do
  (KValue
v, [KValue]
s') <- [KValue] -> IO (KValue, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s; [(Text, KValue)]
-> [KValue] -> [Text] -> IO ([KValue], [(Text, KValue)])
popArgs ((Text
k, KValue
v)(Text, KValue) -> [(Text, KValue)] -> [(Text, KValue)]
forall a. a -> [a] -> [a]
:[(Text, KValue)]
r) [KValue]
s' [Text]
kt

partitionSpecial :: [Identifier] -> ([Identifier], [Identifier])
partitionSpecial :: [Text] -> ([Text], [Text])
partitionSpecial = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"&", Text
"&&"])

-- utilities --

mkOp :: Identifier -> Evaluator -> Builtin
mkOp :: Text -> Evaluator -> Builtin
mkOp = Text -> Evaluator -> Builtin
mkPrim (Text -> Evaluator -> Builtin)
-> (Text -> Text) -> Text -> Evaluator -> Builtin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

len :: [a] -> Integer
len :: [a] -> Integer
len = [a] -> Integer
forall i a. Num i => [a] -> i
genericLength

has :: (a -> Integer) -> a -> Integer -> Bool
has :: (a -> Integer) -> a -> Integer -> Bool
has a -> Integer
l a
x Integer
i = Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< (a -> Integer
l a
x)

lengthT :: Text -> Integer
lengthT :: Text -> Integer
lengthT = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Text -> Int) -> Text -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length

-- TODO
indexT :: Text -> Integer -> Maybe Text
indexT :: Text -> Integer -> Maybe Text
indexT Text
t Integer
i = if (Text -> Integer) -> Text -> Integer -> Bool
forall a. (a -> Integer) -> a -> Integer -> Bool
has Text -> Integer
lengthT Text
t Integer
i then Integer -> Maybe Text
f Integer
i else Maybe Text
forall a. Maybe a
Nothing
  where
    f :: Integer -> Maybe Text
f = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Integer -> Text) -> Integer -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Text) -> (Integer -> Char) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Char
T.index Text
t (Int -> Char) -> (Integer -> Int) -> Integer -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger

-- TODO
slice :: Num a => (a -> b -> b) -> (a -> b -> b)
      -> Integer -> Integer -> Integer -> Integer -> b -> b
slice :: (a -> b -> b)
-> (a -> b -> b)
-> Integer
-> Integer
-> Integer
-> Integer
-> b
-> b
slice a -> b -> b
tak a -> b -> b
drp Integer
i Integer
j Integer
_ Integer
ll b
l = a -> b -> b
tak (Integer -> a
forall a. Num a => Integer -> a
f Integer
j a -> a -> a
forall a. Num a => a -> a -> a
- a
forall a. Num a => a
i') (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ a -> b -> b
drp a
forall a. Num a => a
i' b
l
  where
    f :: Integer -> a
f Integer
n = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a) -> Integer -> a
forall a b. (a -> b) -> a -> b
$ if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer
ll Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n else Integer
n; i' :: a
i' = Integer -> a
forall a. Num a => Integer -> a
f Integer
i

indexOf :: Text -> Text -> Maybe Integer
indexOf :: Text -> Text -> Maybe Integer
indexOf Text
s = Integer -> Text -> Maybe Integer
forall t. Num t => t -> Text -> Maybe t
f Integer
0
  where
    f :: t -> Text -> Maybe t
f t
i Text
t | Text
s Text -> Text -> Bool
`T.isPrefixOf` Text
t  = t -> Maybe t
forall a. a -> Maybe a
Just t
i
    f t
_ Text
""                      = Maybe t
forall a. Maybe a
Nothing
    f t
i Text
t                       = t -> Text -> Maybe t
f (t
it -> t -> t
forall a. Num a => a -> a -> a
+t
1) (Text -> Maybe t) -> Text -> Maybe t
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
t

nilToDef :: FromVal a => KValue -> a -> IO a
nilToDef :: KValue -> a -> IO a
nilToDef KValue
x a
d = if KValue -> Bool
isNil KValue
x then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
d else Either KException a -> IO a
forall a. Either KException a -> IO a
retOrThrow (Either KException a -> IO a) -> Either KException a -> IO a
forall a b. (a -> b) -> a -> b
$ KValue -> Either KException a
forall a. FromVal a => KValue -> Either KException a
fromVal KValue
x

debug :: Context -> IO () -> IO ()
debug :: Context -> IO () -> IO ()
debug Context
c IO ()
act
  = Bool -> (KValue -> Bool) -> Maybe KValue -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (KValue -> KValue -> Bool
forall a. Eq a => a -> a -> Bool
== KValue
true) (Maybe KValue -> Bool) -> IO (Maybe KValue) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Text -> IO (Maybe KValue)
lookup Context
c Text
"__debug__" IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when IO ()
act

-- vim: set tw=70 sw=2 sts=2 et fdm=marker :