{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
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, 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
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
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
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 :: 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
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"
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)
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)
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]
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"
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"
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
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 :: 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"
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"
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 []
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
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
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
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
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
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
"&&"])
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
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
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