{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Koneko.Prim (initCtx, replDef, swap) where
import Control.Arrow ((***))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently)
import Control.DeepSeq (($!!), force, NFData)
import Control.Exception (catch, evaluate, throwIO, try)
import Control.Monad (unless)
import Data.Bits ((.|.))
import Data.Char (chr, isDigit)
import Data.Data (toConstr)
import Data.Foldable (traverse_)
import Data.List (isSuffixOf, sort)
import Data.Text (Text)
import Data.Version (showVersion, versionBranch)
import Prelude hiding (lookup)
import System.Directory (listDirectory)
import System.FilePath ((</>))
import System.Random (getStdRandom, randomR)
#if !MIN_VERSION_GLASGOW_HASKELL(8, 8, 1, 0)
import Data.Monoid ((<>))
#endif
import qualified Control.Exception as E
import qualified Data.Array as A
import qualified Data.ByteString as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.IO as T
import qualified System.Info as I
import qualified Text.Regex.PCRE as RE
import qualified Text.Regex.PCRE.ByteString as RE
import Koneko.Data
import Koneko.Misc (prompt)
import qualified Paths_koneko as P
initCtx :: Context -> (Identifier -> IO ()) -> Evaluator -> Evaluator
-> Evaluator -> (Block -> Evaluator) -> IO ()
initCtx :: Context
-> (Identifier -> IO ())
-> Evaluator
-> Evaluator
-> Evaluator
-> (Block -> Evaluator)
-> IO ()
initCtx Context
ctxMain Identifier -> IO ()
load Evaluator
call Evaluator
apply Evaluator
apply_dict Block -> Evaluator
callBlock = do
Context
ctx <- Identifier -> Context -> IO Context
forkContext Identifier
primModule Context
ctxMain
(Builtin -> IO ()) -> [Builtin] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Context -> Builtin -> IO ()
defPrim Context
ctx) [
Identifier -> Evaluator -> Builtin
mkPrim Identifier
"call" Evaluator
call, Identifier -> Evaluator -> Builtin
mkPrim Identifier
"apply" Evaluator
apply,
Identifier -> Evaluator -> Builtin
mkPrim Identifier
"apply-dict" Evaluator
apply_dict, Evaluator -> Builtin
if' Evaluator
call,
Builtin
def, Builtin
defmulti, Evaluator -> Builtin
defrecord Evaluator
call, Builtin
mkPair, Builtin
mkDict, Builtin
swap,
Builtin
show', Builtin
puts, Builtin
ask, Builtin
types, Builtin
type', Builtin
callable, Builtin
function,
Evaluator -> Builtin
defmodule Evaluator
call, Builtin
modules, Builtin
moduleGet, Builtin
moduleDefs, Builtin
moduleName,
Builtin
import', Builtin
importFrom, (Identifier -> IO ()) -> Builtin
loadModule Identifier -> IO ()
load,
Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
"=" KValue -> KValue -> Bool
forall a. Eq a => a -> a -> Bool
(==), Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
"not=" KValue -> KValue -> Bool
forall a. Eq a => a -> a -> Bool
(/=),
Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
"<" KValue -> KValue -> Bool
forall a. Ord a => a -> a -> Bool
(<) , Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
"<=" KValue -> KValue -> Bool
forall a. Ord a => a -> a -> Bool
(<=),
Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
">" KValue -> KValue -> Bool
forall a. Ord a => a -> a -> Bool
(>) , Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
">=" KValue -> KValue -> Bool
forall a. Ord a => a -> a -> Bool
(>=),
Builtin
spaceship,
Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"eq" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ), Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"neq" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ),
Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"lt" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT), Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"lte" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT),
Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"gt" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT), Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
"gte" (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT),
Builtin
cmp',
Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI Identifier
"int+" Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+), Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI Identifier
"int-" (-), Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI Identifier
"int*" Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*),
Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI Identifier
"div" Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div, Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI Identifier
"mod" Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod,
Identifier -> (Double -> Double -> Double) -> Builtin
arithF Identifier
"float+" Double -> Double -> Double
forall a. Num a => a -> a -> a
(+), Identifier -> (Double -> Double -> Double) -> Builtin
arithF Identifier
"float-" (-),
Identifier -> (Double -> Double -> Double) -> Builtin
arithF Identifier
"float*" Double -> Double -> Double
forall a. Num a => a -> a -> a
(*), Identifier -> (Double -> Double -> Double) -> Builtin
arithF Identifier
"float/" Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/),
Builtin
abs', Builtin
neg,
Identifier -> (Double -> Integer) -> Builtin
floatToInt Identifier
"trunc" (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate), Identifier -> (Double -> Integer) -> Builtin
floatToInt Identifier
"round" (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round),
Identifier -> (Double -> Integer) -> Builtin
floatToInt Identifier
"ceil" (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling) , Identifier -> (Double -> Integer) -> Builtin
floatToInt Identifier
"floor" (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor),
Builtin
chr', Builtin
intToFloat, Builtin
recordToDict,
Builtin
recordType, Builtin
recordVals,
Builtin
recordTypeName, Builtin
recordTypeFields,
(Block -> Evaluator) -> Builtin
mkThunk Block -> Evaluator
callBlock,
Builtin
fail', (Block -> Evaluator) -> Builtin
try' Block -> Evaluator
callBlock,
Builtin
mkIdent, Builtin
mkQuot, Builtin
mkBlock, Builtin
blockParams, Builtin
blockCode,
Builtin
rxMatch, (Block -> Evaluator) -> Builtin
rxSub Block -> Evaluator
callBlock,
(Block -> Evaluator) -> Builtin
par Block -> Evaluator
callBlock, Builtin
sleep,
Builtin
version,
Evaluator -> Builtin
showStack Evaluator
call, Builtin
clearStack, Builtin
nya
]
if', defrecord :: Evaluator -> Builtin
def, defmulti, mkPair, mkDict, swap :: Builtin
if' :: Evaluator -> Builtin
if' Evaluator
call = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"if" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((KValue
cond, KValue
t_br, KValue
f_br), Stack
s') <- Stack -> IO ((KValue, KValue, KValue), Stack)
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
Stack -> IO ((a, b, c), Stack)
pop3' Stack
s
Evaluator
call Context
c (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Stack -> KValue -> Stack
push' Stack
s' (KValue -> Stack) -> KValue -> Stack
forall a b. (a -> b) -> a -> b
$ if KValue -> Bool
truthy KValue
cond then KValue
t_br else KValue
f_br
def :: Builtin
def = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"def" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Kwd Identifier
k, KValue
v), Stack
s') <- Stack -> IO ((Kwd, KValue), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s; Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> Identifier -> KValue -> IO ()
defineIn Context
c Identifier
k KValue
v
defmulti :: Builtin
defmulti = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"defmulti" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Kwd Identifier
k, Stack
sig, Block
b), Stack
s') <- Stack -> IO ((Kwd, Stack, Block), Stack)
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
Stack -> IO ((a, b, c), Stack)
pop3' Stack
s
[Identifier]
sig' <- (Identifier -> IO Identifier) -> [Identifier] -> IO [Identifier]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Context -> Identifier -> IO Identifier
f Context
c) ([Identifier] -> IO [Identifier])
-> IO [Identifier] -> IO [Identifier]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> IO [Identifier]
unKwds Stack
sig
Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> Identifier -> [Identifier] -> Block -> IO ()
defMulti Context
c Identifier
k [Identifier]
sig' Block
b
where
f :: Context -> Identifier -> IO Identifier
f Context
c Identifier
k | Identifier
k Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
"_" Bool -> Bool -> Bool
|| Identifier
k Identifier -> [Identifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Identifier]
typeNames = Identifier -> IO Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
k
| Bool
otherwise = Context -> Identifier -> IO (Maybe KValue)
lookup Context
c Identifier
k IO (Maybe KValue)
-> (Maybe KValue -> IO Identifier) -> IO Identifier
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (KRecordT RecordT
t) -> Identifier -> IO Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> IO Identifier) -> Identifier -> IO Identifier
forall a b. (a -> b) -> a -> b
$ RecordT -> Identifier
recordTypeSig RecordT
t
Just KValue
_ -> KException -> IO Identifier
forall e a. Exception e => e -> IO a
throwIO (KException -> IO Identifier) -> KException -> IO Identifier
forall a b. (a -> b) -> a -> b
$ String -> KException
expected (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be a record-type"
Maybe KValue
_ -> KException -> IO Identifier
forall e a. Exception e => e -> IO a
throwIO (KException -> IO Identifier) -> KException -> IO Identifier
forall a b. (a -> b) -> a -> b
$ String -> KException
NameError (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
k
defrecord :: Evaluator -> Builtin
defrecord Evaluator
call = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"defrecord" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Kwd Identifier
recName, Stack
fs), Stack
s') <- Stack -> IO ((Kwd, Stack), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s; [Identifier]
recFields <- Stack -> IO [Identifier]
unKwds Stack
fs
let t :: RecordT
t = RecordT :: Identifier -> [Identifier] -> RecordT
RecordT{[Identifier]
Identifier
recFields :: [Identifier]
recName :: Identifier
recFields :: [Identifier]
recName :: Identifier
..}; e :: KValue -> IO a
e KValue
x = KValue -> String -> IO a
forall a. KValue -> String -> IO a
err KValue
x (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
recName
Context -> Identifier -> KValue -> IO ()
defineIn Context
c Identifier
recName (KValue -> IO ()) -> KValue -> IO ()
forall a b. (a -> b) -> a -> b
$ RecordT -> KValue
KRecordT RecordT
t
Context -> Identifier -> Evaluator -> IO ()
defX Context
c (Identifier
recName Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"?") (Evaluator -> IO ()) -> Evaluator -> IO ()
forall a b. (a -> b) -> a -> b
$ (KValue -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((KValue -> Bool) -> Evaluator) -> (KValue -> Bool) -> Evaluator
forall a b. (a -> b) -> a -> b
$ RecordT -> (Record -> Bool) -> Bool -> KValue -> Bool
forall p. RecordT -> (Record -> p) -> p -> KValue -> p
m RecordT
t (Bool -> Record -> Bool
forall a b. a -> b -> a
const Bool
True) Bool
False
Context -> Identifier -> Evaluator -> IO ()
defX Context
c (Identifier
"^" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
recName) (Evaluator -> IO ()) -> Evaluator -> IO ()
forall a b. (a -> b) -> a -> b
$ \Context
c1 Stack
s1 -> do
((KValue
x, KValue
f), Stack
s2) <- Stack -> IO ((KValue, KValue), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s1
let go :: Record -> IO Stack
go Record
r = Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> [a] -> IO Stack
rpush Stack
s2 (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Record -> Stack
recValues Record
r Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ [KValue
f]
Evaluator
call Context
c1 (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecordT -> (Record -> IO Stack) -> IO Stack -> KValue -> IO Stack
forall p. RecordT -> (Record -> p) -> p -> KValue -> p
m RecordT
t Record -> IO Stack
go (KValue -> IO Stack
forall a. KValue -> IO a
e KValue
x) KValue
x
Context -> Identifier -> Evaluator -> IO ()
defX Context
c (Identifier
"~" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
recName) (Evaluator -> IO ()) -> Evaluator -> IO ()
forall a b. (a -> b) -> a -> b
$ \Context
c1 Stack
s1 -> do
((KValue
x, KValue
f, KValue
g), Stack
s2) <- Stack -> IO ((KValue, KValue, KValue), Stack)
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
Stack -> IO ((a, b, c), Stack)
pop3' Stack
s1
let go :: Record -> Stack
go Record
r = Record -> Stack
recValues Record
r Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ [KValue
f]
Evaluator
call Context
c1 (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> [a] -> IO Stack
rpush Stack
s2 (RecordT -> (Record -> Stack) -> Stack -> KValue -> Stack
forall p. RecordT -> (Record -> p) -> p -> KValue -> p
m RecordT
t Record -> Stack
go [KValue
g] KValue
x)
Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return Stack
s'
where
m :: RecordT -> (Record -> p) -> p -> KValue -> p
m RecordT
t Record -> p
f p
d = \case KRecord Record
r | Record -> RecordT
recType Record
r RecordT -> RecordT -> Bool
forall a. Eq a => a -> a -> Bool
== RecordT
t -> Record -> p
f Record
r; KValue
_ -> p
d
defX :: Context -> Identifier -> Evaluator -> IO ()
defX Context
c Identifier
k = Context -> Identifier -> KValue -> IO ()
defineIn Context
c Identifier
k (KValue -> IO ()) -> (Evaluator -> KValue) -> Evaluator -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtin -> KValue
KBuiltin (Builtin -> KValue)
-> (Evaluator -> Builtin) -> Evaluator -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Identifier -> Evaluator -> Builtin
mkBltn (Scope -> Identifier
modName (Context -> Scope
ctxScope Context
c) Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
":" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
k)
err :: KValue -> String -> IO a
err KValue
x String
t = 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
$ Either String KValue -> String -> KException
stackExpected (String -> Either String KValue
forall a b. a -> Either a b
Left (String -> Either String KValue) -> String -> Either String KValue
forall a b. (a -> b) -> a -> b
$ KValue -> String
tp KValue
x)
(String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ String
"record of type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
t
tp :: KValue -> String
tp = \case KRecord Record
r -> String
"record of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Identifier -> String
T.unpack (RecordT -> Identifier
recName (RecordT -> Identifier) -> RecordT -> Identifier
forall a b. (a -> b) -> a -> b
$ Record -> RecordT
recType Record
r)
KValue
x -> KValue -> String
forall a. IsString a => KValue -> a
typeAsStr KValue
x
mkPair :: Builtin
mkPair = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"=>" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Kwd -> KValue -> Pair) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 Kwd -> KValue -> Pair
Pair
mkDict :: Builtin
mkDict = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"dict" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Stack
l, Stack
s') <- Stack -> IO (Stack, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (KValue -> IO Stack) -> IO KValue -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Pair] -> KValue
dict ([Pair] -> KValue) -> IO [Pair] -> IO KValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either KException [Pair] -> IO [Pair]
forall a. Either KException a -> IO a
retOrThrow (Either KException [Pair] -> IO [Pair])
-> Either KException [Pair] -> IO [Pair]
forall a b. (a -> b) -> a -> b
$ Stack -> Either KException [Pair]
forall a. FromVal a => Stack -> Either KException [a]
fromVals Stack
l)
swap :: Builtin
swap = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"swap" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> Stack) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> [c]) -> Evaluator
pop2push ((KValue -> KValue -> Stack) -> Evaluator)
-> (KValue -> KValue -> Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \KValue
x KValue
y -> [KValue
y, KValue
x] :: [KValue]
show', puts, ask, types, type', callable, function :: Builtin
show' :: Builtin
show' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"show" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> Identifier) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((KValue -> Identifier) -> Evaluator)
-> (KValue -> Identifier) -> Evaluator
forall a b. (a -> b) -> a -> b
$ String -> Identifier
T.pack (String -> Identifier)
-> (KValue -> String) -> KValue -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KValue -> String
forall a. Show a => a -> String
show :: KValue -> String)
puts :: Builtin
puts = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"puts!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do (Identifier
x, Stack
s') <- Stack -> IO (Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Identifier -> IO ()
T.putStr Identifier
x
ask :: Builtin
ask = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"ask!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Maybe Identifier
x, Stack
s') <- Stack -> IO (Maybe Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; Maybe Identifier -> IO (Maybe Identifier)
prompt Maybe Identifier
x IO (Maybe Identifier) -> (Maybe Identifier -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Maybe Identifier -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s'
types :: Builtin
types = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"types" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Stack -> IO Stack) -> Evaluator
forall a b. a -> b -> a
const ((Stack -> IO Stack) -> Evaluator)
-> (Stack -> IO Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Stack -> Stack -> IO Stack) -> Stack -> Stack -> IO Stack
forall a b c. (a -> b -> c) -> b -> a -> c
flip Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 (Stack -> Stack -> IO Stack) -> Stack -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
kwd [Identifier]
typeNames
type' :: Builtin
type' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"type" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> Kwd) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((KValue -> Kwd) -> Evaluator) -> (KValue -> Kwd) -> Evaluator
forall a b. (a -> b) -> a -> b
$ KType -> Kwd
typeToKwd (KType -> Kwd) -> (KValue -> KType) -> KValue -> Kwd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
callable :: Builtin
callable = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"callable?" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 KValue -> Bool
isCallable
function :: Builtin
function = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"function?" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> Bool) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 KValue -> Bool
isFunction
defmodule :: Evaluator -> Builtin
modules, moduleGet, moduleDefs, moduleName, import', importFrom :: Builtin
defmodule :: Evaluator -> Builtin
defmodule Evaluator
call = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"defmodule" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Kwd Identifier
m, Block
b), Stack
s') <- Stack -> IO ((Kwd, Block), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s; Context
c' <- Identifier -> Context -> IO Context
forkContext Identifier
m Context
c
Evaluator
call Context
c (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Stack -> KValue -> Stack
forall a. ToVal a => Stack -> a -> Stack
push Stack
s' (KValue -> Stack) -> KValue -> Stack
forall a b. (a -> b) -> a -> b
$ Block -> KValue
KBlock 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' }
modules :: Builtin
modules = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"modules" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
Stack -> Stack
forall a. Ord a => [a] -> [a]
sort (Stack -> Stack)
-> ([Identifier] -> Stack) -> [Identifier] -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
kwd ([Identifier] -> Stack) -> IO [Identifier] -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO [Identifier]
moduleNames Context
c IO Stack -> (Stack -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s
moduleGet :: Builtin
moduleGet = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"module-get" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Kwd Identifier
k, Kwd Identifier
m), Stack
s') <- Stack -> IO ((Kwd, Kwd), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
Context -> Identifier -> Identifier -> IO KValue
lookupModule' Context
c Identifier
k Identifier
m IO KValue -> (KValue -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s'
moduleDefs :: Builtin
moduleDefs = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"module-defs" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
(Kwd Identifier
m, Stack
s') <- Stack -> IO (Kwd, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
Stack -> Stack
forall a. Ord a => [a] -> [a]
sort (Stack -> Stack)
-> ([Identifier] -> Stack) -> [Identifier] -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
kwd ([Identifier] -> Stack) -> IO [Identifier] -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Identifier -> IO [Identifier]
moduleKeys Context
c Identifier
m IO Stack -> (Stack -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s'
moduleName :: Builtin
moduleName = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"name" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s ->
Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s (KValue -> IO Stack) -> KValue -> IO Stack
forall a b. (a -> b) -> a -> b
$ Identifier -> KValue
kwd (Identifier -> KValue) -> Identifier -> KValue
forall a b. (a -> b) -> a -> b
$ Scope -> Identifier
modName (Scope -> Identifier) -> Scope -> Identifier
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c
import' :: Builtin
import' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"import" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
(Kwd Identifier
m, Stack
s') <- Stack -> IO (Kwd, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> Identifier -> IO ()
importIn Context
c Identifier
m
importFrom :: Builtin
importFrom = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"import-from" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Stack
ks, Kwd Identifier
m), Stack
s') <- Stack -> IO ((Stack, Kwd), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s; Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Context -> Identifier -> [Identifier] -> IO ()
importFromIn Context
c Identifier
m ([Identifier] -> IO ()) -> IO [Identifier] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> IO [Identifier]
unKwds Stack
ks)
loadModule :: (Identifier -> IO ()) -> Builtin
loadModule :: (Identifier -> IO ()) -> Builtin
loadModule Identifier -> IO ()
load = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"load-module" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Kwd Identifier
m, Stack
s') <- Stack -> IO (Kwd, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Identifier -> IO ()
load Identifier
m
comp :: Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp :: Identifier -> (KValue -> KValue -> Bool) -> Builtin
comp Identifier
name = Identifier -> Evaluator -> Builtin
mkPrim Identifier
name (Evaluator -> Builtin)
-> ((KValue -> KValue -> Bool) -> Evaluator)
-> (KValue -> KValue -> Bool)
-> Builtin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KValue -> KValue -> Bool) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1
comp' :: Identifier -> (Ordering -> Bool) -> Builtin
comp' :: Identifier -> (Ordering -> Bool) -> Builtin
comp' Identifier
name Ordering -> Bool
f = Identifier -> Evaluator -> Builtin
mkPrim Identifier
name (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> Bool) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 ((KValue -> KValue -> Bool) -> Evaluator)
-> (KValue -> KValue -> Bool) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \KValue
x KValue
y -> Ordering -> Bool
f (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ KValue -> KValue -> Ordering
_cmp' KValue
x KValue
y
spaceship, cmp' :: Builtin
spaceship :: Builtin
spaceship = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"<=>" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> Integer) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 ((KValue -> KValue -> Integer) -> Evaluator)
-> (KValue -> KValue -> Integer) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \KValue
x KValue
y -> Ordering -> Integer
_ordToInt (Ordering -> Integer) -> Ordering -> Integer
forall a b. (a -> b) -> a -> b
$ KValue -> KValue -> Ordering
_cmp KValue
x KValue
y
cmp' :: Builtin
cmp' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"cmp" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> Integer) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 ((KValue -> KValue -> Integer) -> Evaluator)
-> (KValue -> KValue -> Integer) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \KValue
x KValue
y -> Ordering -> Integer
_ordToInt (Ordering -> Integer) -> Ordering -> Integer
forall a b. (a -> b) -> a -> b
$ KValue -> KValue -> Ordering
_cmp' KValue
x KValue
y
_cmp, _cmp' :: KValue -> KValue -> Ordering
_cmp :: KValue -> KValue -> Ordering
_cmp = KValue -> KValue -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
_cmp' :: KValue -> KValue -> Ordering
_cmp' = KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp
_ordToInt :: Ordering -> Integer
_ordToInt :: Ordering -> Integer
_ordToInt Ordering
LT = -Integer
1
_ordToInt Ordering
EQ = Integer
0
_ordToInt Ordering
GT = Integer
1
arith :: (FromVal a, ToVal a, NFData a)
=> Identifier -> (a -> a -> a) -> Builtin
arith :: Identifier -> (a -> a -> a) -> Builtin
arith Identifier
name a -> a -> a
op = Identifier -> Evaluator -> Builtin
mkPrim Identifier
name (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
((a
x, a
y), Stack
s') <- Stack -> IO ((a, a), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
Stack -> a -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (a -> IO Stack) -> IO a -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO a -> IO a
forall a. IO a -> IO a
f (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. NFData a => a -> a
force (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
op a
x a
y)
where
f :: IO a -> IO a
f = (IO a -> (ArithException -> IO a) -> IO a)
-> (ArithException -> IO a) -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> (ArithException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((ArithException -> IO a) -> IO a -> IO a)
-> (ArithException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \case ArithException
E.DivideByZero -> KException -> IO a
forall e a. Exception e => e -> IO a
throwIO KException
DivideByZero
ArithException
e -> ArithException -> IO a
forall e a. Exception e => e -> IO a
throwIO ArithException
e
arithI :: Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithF :: Identifier -> (Double -> Double -> Double ) -> Builtin
arithI :: Identifier -> (Integer -> Integer -> Integer) -> Builtin
arithI = Identifier -> (Integer -> Integer -> Integer) -> Builtin
forall a.
(FromVal a, ToVal a, NFData a) =>
Identifier -> (a -> a -> a) -> Builtin
arith
arithF :: Identifier -> (Double -> Double -> Double) -> Builtin
arithF = Identifier -> (Double -> Double -> Double) -> Builtin
forall a.
(FromVal a, ToVal a, NFData a) =>
Identifier -> (a -> a -> a) -> Builtin
arith
abs', neg :: Builtin
abs' :: Builtin
abs' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"abs" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Either Integer Double -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Either Integer Double -> KValue) -> Evaluator)
-> (Either Integer Double -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Integer -> KValue)
-> (Double -> KValue) -> Either Integer Double -> KValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(Integer -> KValue
forall a. ToVal a => a -> KValue
toVal (Integer -> KValue) -> (Integer -> Integer) -> Integer -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer
forall a. Num a => a -> a
abs :: Integer -> Integer))
(Double -> KValue
forall a. ToVal a => a -> KValue
toVal (Double -> KValue) -> (Double -> Double) -> Double -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double
forall a. Num a => a -> a
abs :: Double -> Double ))
neg :: Builtin
neg = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"neg" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Either Integer Double -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Either Integer Double -> KValue) -> Evaluator)
-> (Either Integer Double -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Integer -> KValue)
-> (Double -> KValue) -> Either Integer Double -> KValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(Integer -> KValue
forall a. ToVal a => a -> KValue
toVal (Integer -> KValue) -> (Integer -> Integer) -> Integer -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer
forall a. Num a => a -> a
negate :: Integer -> Integer))
(Double -> KValue
forall a. ToVal a => a -> KValue
toVal (Double -> KValue) -> (Double -> Double) -> Double -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double
forall a. Num a => a -> a
negate :: Double -> Double ))
floatToInt :: Identifier -> (Double -> Integer) -> Builtin
floatToInt :: Identifier -> (Double -> Integer) -> Builtin
floatToInt Identifier
name Double -> Integer
f = Identifier -> Evaluator -> Builtin
mkPrim Identifier
name (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Double -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 Double -> KValue
g
where
g :: Double -> KValue
g Double
n = if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
n Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n then KValue
nil else Integer -> KValue
int (Integer -> KValue) -> Integer -> KValue
forall a b. (a -> b) -> a -> b
$ Double -> Integer
f Double
n
chr', intToFloat, recordToDict :: Builtin
chr' :: Builtin
chr' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"chr" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Integer
i, Stack
s') <- Stack -> IO (Integer, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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
< Integer
0x110000) (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 String KValue -> String -> KException
stackExpected (String -> Either String KValue
forall a b. a -> Either a b
Left (String -> Either String KValue) -> String -> Either String KValue
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i) String
"int in range [0,0x110000)"
Stack -> Identifier -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (Identifier -> IO Stack) -> Identifier -> IO Stack
forall a b. (a -> b) -> a -> b
$ Char -> Identifier
T.singleton (Char -> Identifier) -> Char -> Identifier
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
intToFloat :: Builtin
intToFloat
= Identifier -> Evaluator -> Builtin
mkPrim Identifier
"int->float" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Integer -> Double) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 (Integer -> Double
forall a. Num a => Integer -> a
fromInteger :: Integer -> Double)
recordToDict :: Builtin
recordToDict = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"record->dict" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Record -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Record -> KValue) -> Evaluator)
-> (Record -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ [Pair] -> KValue
dict ([Pair] -> KValue) -> (Record -> [Pair]) -> Record -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record -> [Pair]
recordToPairs
recordType, recordVals :: Builtin
recordType :: Builtin
recordType = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"record-type" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Record -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Record -> KValue) -> Evaluator)
-> (Record -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ RecordT -> KValue
KRecordT (RecordT -> KValue) -> (Record -> RecordT) -> Record -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record -> RecordT
recType
recordVals :: Builtin
recordVals = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"record-values" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Record -> Stack) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Record -> Stack) -> Evaluator) -> (Record -> Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ Record -> Stack
recValues
recordTypeName, recordTypeFields :: Builtin
recordTypeName :: Builtin
recordTypeName = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"record-type-name" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (RecordT -> Kwd) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((RecordT -> Kwd) -> Evaluator) -> (RecordT -> Kwd) -> Evaluator
forall a b. (a -> b) -> a -> b
$ Identifier -> Kwd
Kwd (Identifier -> Kwd) -> (RecordT -> Identifier) -> RecordT -> Kwd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordT -> Identifier
recName
recordTypeFields :: Builtin
recordTypeFields = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"record-type-fields" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (RecordT -> Stack) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1
((RecordT -> Stack) -> Evaluator)
-> (RecordT -> Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
kwd ([Identifier] -> Stack)
-> (RecordT -> [Identifier]) -> RecordT -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordT -> [Identifier]
recFields
mkThunk :: (Block -> Evaluator) -> Builtin
mkThunk :: (Block -> Evaluator) -> Builtin
mkThunk Block -> Evaluator
callBlock = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"thunk" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
(Block
b, Stack
s') <- Stack -> IO (Block, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
Thunk
t <- IO KValue -> IO Thunk
thunk (IO KValue -> IO Thunk) -> IO KValue -> IO Thunk
forall a b. (a -> b) -> a -> b
$ do
Stack
l <- Block -> Evaluator
callBlock Block
b Context
c Stack
emptyStack
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Stack -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Stack
l 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
$
String -> KException
expected String
"thunk to produce exactly 1 value"
KValue -> IO KValue
forall (m :: * -> *) a. Monad m => a -> m a
return (KValue -> IO KValue) -> KValue -> IO KValue
forall a b. (a -> b) -> a -> b
$ Stack -> KValue
forall a. [a] -> a
head Stack
l
Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (KValue -> IO Stack) -> KValue -> IO Stack
forall a b. (a -> b) -> a -> b
$ Thunk -> KValue
KThunk Thunk
t
fail' :: Builtin
fail' :: Builtin
fail' = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"fail" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Identifier
msg, Stack
_) <- Stack -> IO (Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; KException -> IO Stack
forall e a. Exception e => e -> IO a
throwIO (KException -> IO Stack) -> KException -> IO Stack
forall a b. (a -> b) -> a -> b
$ String -> KException
Fail (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
msg
try' :: (Block -> Evaluator) -> Builtin
try' :: (Block -> Evaluator) -> Builtin
try' Block -> Evaluator
callBlock = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"try" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s0 -> do
((Block
f, Maybe Block
g, Block
h), Stack
s1) <- Stack -> IO ((Block, Maybe Block, Block), Stack)
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
Stack -> IO ((a, b, c), Stack)
pop3' Stack
s0
Either KException Stack
r <- IO Stack -> IO (Either KException Stack)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Stack -> IO (Either KException Stack))
-> IO Stack -> IO (Either KException Stack)
forall a b. (a -> b) -> a -> b
$ (Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. NFData a => (a -> b) -> a -> b
$!!) (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Block -> Evaluator
callBlock Block
f Context
c Stack
emptyStack
(KValue
b, Stack
s3) <- Stack -> IO (KValue, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' (Stack -> IO (KValue, Stack)) -> IO Stack -> IO (KValue, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (KException -> IO Stack)
-> (Stack -> IO Stack) -> Either KException Stack -> IO Stack
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Block -> Stack -> IO Stack)
-> Maybe Block -> KException -> IO Stack
forall (m :: * -> *) t.
Monad m =>
(t -> Stack -> m Stack) -> Maybe t -> KException -> m Stack
cat ((Block -> Evaluator) -> Context -> Block -> Stack -> IO Stack
forall a b c. (a -> b -> c) -> b -> a -> c
flip Block -> Evaluator
callBlock Context
c) Maybe Block
g)
(Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> IO Stack) -> (Stack -> Stack) -> Stack -> IO Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack -> KValue -> Stack
forall a. ToVal a => Stack -> a -> Stack
`push` KValue
false)) Either KException Stack
r
Stack
s4 <- (Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ Stack
s3 Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ Stack
s1) (Stack -> Stack) -> IO Stack -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block -> Evaluator
callBlock Block
h Context
c Stack
emptyStack
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KValue -> Bool
truthy KValue
b) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (KException -> IO ())
-> (Stack -> IO ()) -> Either KException Stack -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IO () -> Stack -> IO ()
forall a b. a -> b -> a
const (IO () -> Stack -> IO ()) -> IO () -> Stack -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Either KException Stack
r
Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return Stack
s4
where
cat :: (t -> Stack -> m Stack) -> Maybe t -> KException -> m Stack
cat t -> Stack -> m Stack
cb Maybe t
g KException
e = m Stack -> (t -> m Stack) -> Maybe t -> m Stack
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Stack -> m Stack
forall (m :: * -> *) a. Monad m => a -> m a
return [KValue
false]) (\t
b -> t -> Stack -> m Stack
cb t
b (Stack -> m Stack) -> Stack -> m Stack
forall a b. (a -> b) -> a -> b
$ KException -> Stack
_errInfo KException
e) Maybe t
g
_errInfo :: KException -> [KValue]
_errInfo :: KException -> Stack
_errInfo KException
e = [[Identifier] -> KValue
forall a. ToVal a => [a] -> KValue
list ([Identifier] -> KValue) -> [Identifier] -> KValue
forall a b. (a -> b) -> a -> b
$ (String -> Identifier) -> [String] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map String -> Identifier
T.pack ([String] -> [Identifier]) -> [String] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ KException -> [String]
exceptionInfo KException
e,
Identifier -> KValue
str (Identifier -> KValue) -> Identifier -> KValue
forall a b. (a -> b) -> a -> b
$ String -> Identifier
T.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ KException -> String
forall a. Show a => a -> String
show KException
e, Identifier -> KValue
kwd (Identifier -> KValue) -> Identifier -> KValue
forall a b. (a -> b) -> a -> b
$ String -> Identifier
T.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Constr -> String
forall a. Show a => a -> String
show (Constr -> String) -> Constr -> String
forall a b. (a -> b) -> a -> b
$ KException -> Constr
forall a. Data a => a -> Constr
toConstr KException
e]
mkIdent, mkQuot, mkBlock, blockParams, blockCode :: Builtin
mkIdent :: Builtin
mkIdent = Identifier -> (Ident -> KValue) -> Builtin
_mkIQ Identifier
"ident" Ident -> KValue
KIdent
mkQuot :: Builtin
mkQuot = Identifier -> (Ident -> KValue) -> Builtin
_mkIQ Identifier
"quot" Ident -> KValue
KQuot
mkBlock :: Builtin
mkBlock = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"block" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
((Stack
ps, Stack
code, Block
b), Stack
s') <- Stack -> IO ((Stack, Stack, Block), Stack)
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
Stack -> IO ((a, b, c), Stack)
pop3' Stack
s
[Ident]
ps' <- (Identifier -> IO Ident) -> [Identifier] -> IO [Ident]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Identifier -> IO Ident
_mkId ([Identifier] -> IO [Ident]) -> IO [Identifier] -> IO [Ident]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> IO [Identifier]
unKwds Stack
ps
Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (KValue -> IO Stack) -> KValue -> IO Stack
forall a b. (a -> b) -> a -> b
$ [Ident] -> Stack -> Maybe Scope -> KValue
block [Ident]
ps' Stack
code (Maybe Scope -> KValue) -> Maybe Scope -> KValue
forall a b. (a -> b) -> a -> b
$ Block -> Maybe Scope
blkScope Block
b
blockParams :: Builtin
blockParams = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"block-params" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Block -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Block -> KValue) -> Evaluator) -> (Block -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$
Stack -> KValue
forall a. ToVal a => [a] -> KValue
list (Stack -> KValue) -> (Block -> Stack) -> Block -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> KValue) -> [Ident] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map (Identifier -> KValue
kwd (Identifier -> KValue) -> (Ident -> Identifier) -> Ident -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Identifier
unIdent) ([Ident] -> Stack) -> (Block -> [Ident]) -> Block -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Ident]
blkParams
blockCode :: Builtin
blockCode = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"block-code" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Block -> Stack) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 Block -> Stack
blkCode
_mkIQ :: Identifier -> (Ident -> KValue) -> Builtin
_mkIQ :: Identifier -> (Ident -> KValue) -> Builtin
_mkIQ Identifier
n Ident -> KValue
f = Identifier -> Evaluator -> Builtin
mkPrim Identifier
n (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Kwd Identifier
k, Stack
s') <- Stack -> IO (Kwd, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s; Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (KValue -> IO Stack) -> IO KValue -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> KValue
f (Ident -> KValue) -> IO Ident -> IO KValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> IO Ident
_mkId Identifier
k
_mkId :: Identifier -> IO Ident
_mkId :: Identifier -> IO Ident
_mkId Identifier
k = IO Ident -> (Ident -> IO Ident) -> Maybe Ident -> IO Ident
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Ident
forall a. IO a
err Ident -> IO Ident
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ident -> IO Ident) -> Maybe Ident -> IO Ident
forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe Ident
ident Identifier
k
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
$ String -> KException
expected (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be a valid ident"
rxMatch :: Builtin
rxMatch :: Builtin
rxMatch = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"rx-match" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
((Identifier
x, Identifier
r), Stack
s') <- Stack -> IO ((Identifier, Identifier), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
Stack -> Maybe KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (Maybe KValue -> IO Stack) -> IO (Maybe KValue) -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe (Identifier, [Identifier], Identifier) -> Maybe KValue
forall a c. Maybe (a, [Identifier], c) -> Maybe KValue
f (Maybe (Identifier, [Identifier], Identifier) -> Maybe KValue)
-> (Regex -> Maybe (Identifier, [Identifier], Identifier))
-> Regex
-> Maybe KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
_rxGetMatches (Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier))
-> (Regex -> Maybe (ByteString, MatchText ByteString, ByteString))
-> Regex
-> Maybe (Identifier, [Identifier], Identifier)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier
-> Regex -> Maybe (ByteString, MatchText ByteString, ByteString)
_rxMatch Identifier
x) (Regex -> Maybe KValue) -> IO Regex -> IO (Maybe KValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> IO Regex
_rxCompile Identifier
r
where
f :: Maybe (a, [Identifier], c) -> Maybe KValue
f = ((a, [Identifier], c) -> KValue)
-> Maybe (a, [Identifier], c) -> Maybe KValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, [Identifier], c) -> KValue)
-> Maybe (a, [Identifier], c) -> Maybe KValue)
-> ((a, [Identifier], c) -> KValue)
-> Maybe (a, [Identifier], c)
-> Maybe KValue
forall a b. (a -> b) -> a -> b
$ \(a
_, [Identifier]
m, c
_) -> [Identifier] -> KValue
forall a. ToVal a => [a] -> KValue
list [Identifier]
m
rxSub :: (Block -> Evaluator) -> Builtin
rxSub :: (Block -> Evaluator) -> Builtin
rxSub Block -> Evaluator
callBlock = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"rx-sub" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Identifier
x, Either Identifier Block
s_b, Identifier
r, Bool
glob), Stack
s') <- Stack
-> IO
((Identifier, Either Identifier Block, Identifier, Bool), Stack)
forall a b c d.
(FromVal a, FromVal b, FromVal c, FromVal d) =>
Stack -> IO ((a, b, c, d), Stack)
pop4' Stack
s; Regex
rx <-Identifier -> IO Regex
_rxCompile Identifier
r
let strsub :: Identifier -> [Identifier] -> m Identifier
strsub Identifier
t [Identifier]
m = Identifier -> m Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> m Identifier) -> Identifier -> m Identifier
forall a b. (a -> b) -> a -> b
$ Identifier -> [Identifier] -> Identifier
_dollar Identifier
t [Identifier]
m
blksub :: Block -> [Identifier] -> IO b
blksub Block
b [Identifier]
m = do
Stack
l <- Block -> Evaluator
callBlock Block
b Context
c (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Stack -> Stack
forall a. [a] -> [a]
reverse (Stack -> Stack) -> Stack -> Stack
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
str [Identifier]
m
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Stack -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Stack
l 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
$
String -> KException
expected String
"rx-sub block to produce exactly 1 value"
(b, Stack) -> b
forall a b. (a, b) -> a
fst ((b, Stack) -> b) -> IO (b, Stack) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> IO (b, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
l
sub :: [Identifier] -> IO Identifier
sub = (Identifier -> [Identifier] -> IO Identifier)
-> (Block -> [Identifier] -> IO Identifier)
-> Either Identifier Block
-> [Identifier]
-> IO Identifier
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Identifier -> [Identifier] -> IO Identifier
forall (m :: * -> *).
Monad m =>
Identifier -> [Identifier] -> m Identifier
strsub Block -> [Identifier] -> IO Identifier
forall b. FromVal b => Block -> [Identifier] -> IO b
blksub Either Identifier Block
s_b
sub1 :: (Identifier, [Identifier], Identifier) -> IO Identifier
sub1 (Identifier
bf,[Identifier]
m,Identifier
af) = do Identifier
t <- [Identifier] -> IO Identifier
sub [Identifier]
m; Identifier -> IO Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> IO Identifier) -> Identifier -> IO Identifier
forall a b. (a -> b) -> a -> b
$ Identifier
bf Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
t Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
af
Stack -> Identifier -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (Identifier -> IO Stack) -> IO Identifier -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Bool
glob
then Identifier
-> (Identifier -> Identifier) -> Maybe Identifier -> Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Identifier
x Identifier -> Identifier
forall a. a -> a
id (Maybe Identifier -> Identifier)
-> IO (Maybe Identifier) -> IO Identifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> [MatchText ByteString]
-> ([Identifier] -> IO Identifier)
-> IO (Maybe Identifier)
_rxReplaceAll (Identifier -> ByteString
E.encodeUtf8 Identifier
x) (Identifier -> Regex -> [MatchText ByteString]
_rxMatchAll Identifier
x Regex
rx) [Identifier] -> IO Identifier
sub
else IO Identifier
-> ((Identifier, [Identifier], Identifier) -> IO Identifier)
-> Maybe (Identifier, [Identifier], Identifier)
-> IO Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Identifier -> IO Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
x) (Identifier, [Identifier], Identifier) -> IO Identifier
sub1 (Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
_rxGetMatches (Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier))
-> Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
forall a b. (a -> b) -> a -> b
$ Identifier
-> Regex -> Maybe (ByteString, MatchText ByteString, ByteString)
_rxMatch Identifier
x Regex
rx)
_dollar :: Text -> [Text] -> Text
_dollar :: Identifier -> [Identifier] -> Identifier
_dollar Identifier
_ [] = String -> Identifier
forall a. HasCallStack => String -> a
error String
"WTF"
_dollar Identifier
t [Identifier]
m = String -> Identifier
T.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ String -> String
f (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
t
where
f :: String -> String
f (Char
'$':Char
'$':String
t_) = Char
'$' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
f String
t_
f (Char
'$':Char
'&':String
t_) = Int -> String
g Int
0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
f String
t_
f (Char
'$':Char
i:Char
j:String
t_) | Char -> Bool
otn Char
i Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
j Bool -> Bool -> Bool
&& Int -> Bool
ok Int
n = Int -> String
g Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
f String
t_
where n :: Int
n = String -> Int
forall a. Read a => String -> a
read [Char
i,Char
j]
f (Char
'$':Char
i: String
t_) | Char -> Bool
otn Char
i Bool -> Bool -> Bool
&& Int -> Bool
ok Int
n = Int -> String
g Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
f String
t_
where n :: Int
n = String -> Int
forall a. Read a => String -> a
read [Char
i]
f (Char
c:String
t_) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
f String
t_
f [] = []
otn :: Char -> Bool
otn Char
i = Char -> Bool
isDigit Char
i Bool -> Bool -> Bool
&& Char
i Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0'
ok :: Int -> Bool
ok Int
n = Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l
g :: Int -> String
g Int
n = Identifier -> String
T.unpack (Identifier -> String) -> Identifier -> String
forall a b. (a -> b) -> a -> b
$ [Identifier]
m [Identifier] -> Int -> Identifier
forall a. [a] -> Int -> a
!! Int
n
l :: Int
l = [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
m
_rxCompile :: Text -> IO RE.Regex
_rxCompile :: Identifier -> IO Regex
_rxCompile Identifier
x = Identifier -> IO (Either (Int, String) Regex)
f Identifier
x IO (Either (Int, String) Regex)
-> (Either (Int, String) Regex -> IO Regex) -> IO Regex
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Int, String) -> IO Regex)
-> (Regex -> IO Regex) -> Either (Int, String) Regex -> IO Regex
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (KException -> IO Regex
forall e a. Exception e => e -> IO a
throwIO (KException -> IO Regex)
-> ((Int, String) -> KException) -> (Int, String) -> IO Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> KException
InvalidRx (String -> KException)
-> ((Int, String) -> String) -> (Int, String) -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> String
forall a. Show a => a -> String
show) Regex -> IO Regex
forall (m :: * -> *) a. Monad m => a -> m a
return
where
f :: Identifier -> IO (Either (Int, String) Regex)
f = CompOption
-> ExecOption -> ByteString -> IO (Either (Int, String) Regex)
RE.compile CompOption
c ExecOption
RE.execBlank (ByteString -> IO (Either (Int, String) Regex))
-> (Identifier -> ByteString)
-> Identifier
-> IO (Either (Int, String) Regex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
E.encodeUtf8
c :: CompOption
c = CompOption
RE.compBlank CompOption -> CompOption -> CompOption
forall a. Bits a => a -> a -> a
.|. CompOption
RE.compUTF8 CompOption -> CompOption -> CompOption
forall a. Bits a => a -> a -> a
.|. CompOption
RE.compDollarEndOnly
_rxMatch
:: Text -> RE.Regex
-> Maybe (BL.ByteString, RE.MatchText BL.ByteString, BL.ByteString)
_rxMatch :: Identifier
-> Regex -> Maybe (ByteString, MatchText ByteString, ByteString)
_rxMatch Identifier
s Regex
r = Regex
-> ByteString
-> Maybe (ByteString, MatchText ByteString, ByteString)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
RE.matchOnceText Regex
r (ByteString
-> Maybe (ByteString, MatchText ByteString, ByteString))
-> ByteString
-> Maybe (ByteString, MatchText ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Identifier -> ByteString
E.encodeUtf8 Identifier
s
_rxMatchAll :: Text -> RE.Regex -> [RE.MatchText BL.ByteString]
_rxMatchAll :: Identifier -> Regex -> [MatchText ByteString]
_rxMatchAll Identifier
s Regex
r = Regex -> ByteString -> [MatchText ByteString]
forall regex source.
RegexLike regex source =>
regex -> source -> [MatchText source]
RE.matchAllText Regex
r (ByteString -> [MatchText ByteString])
-> ByteString -> [MatchText ByteString]
forall a b. (a -> b) -> a -> b
$ Identifier -> ByteString
E.encodeUtf8 Identifier
s
_rxGetMatches
:: Maybe (BL.ByteString, RE.MatchText BL.ByteString, BL.ByteString)
-> Maybe (Text, [Text], Text)
_rxGetMatches :: Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
_rxGetMatches
= ((ByteString, MatchText ByteString, ByteString)
-> (Identifier, [Identifier], Identifier))
-> Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ByteString, MatchText ByteString, ByteString)
-> (Identifier, [Identifier], Identifier))
-> Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier))
-> ((ByteString, MatchText ByteString, ByteString)
-> (Identifier, [Identifier], Identifier))
-> Maybe (ByteString, MatchText ByteString, ByteString)
-> Maybe (Identifier, [Identifier], Identifier)
forall a b. (a -> b) -> a -> b
$ \(ByteString
b,MatchText ByteString
m,ByteString
a) -> (ByteString -> Identifier
E.decodeUtf8 ByteString
b, MatchText ByteString -> [Identifier]
_rxMatches MatchText ByteString
m, ByteString -> Identifier
E.decodeUtf8 ByteString
a)
_rxReplaceAll
:: BL.ByteString -> [RE.MatchText BL.ByteString]
-> ([Text] -> IO Text) -> IO (Maybe Text)
_rxReplaceAll :: ByteString
-> [MatchText ByteString]
-> ([Identifier] -> IO Identifier)
-> IO (Maybe Identifier)
_rxReplaceAll ByteString
_ [] [Identifier] -> IO Identifier
_ = Maybe Identifier -> IO (Maybe Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Identifier
forall a. Maybe a
Nothing
_rxReplaceAll ByteString
src [MatchText ByteString]
ms [Identifier] -> IO Identifier
sub = Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just (Identifier -> Maybe Identifier)
-> ([[Identifier]] -> Identifier)
-> [[Identifier]]
-> Maybe Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier] -> Identifier
T.concat ([Identifier] -> Identifier)
-> ([[Identifier]] -> [Identifier]) -> [[Identifier]] -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Identifier]] -> [Identifier]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Identifier]] -> Maybe Identifier)
-> IO [[Identifier]] -> IO (Maybe Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ByteString -> [MatchText ByteString] -> IO [[Identifier]]
f Int
0 ByteString
src [MatchText ByteString]
ms
where
f :: Int -> ByteString -> [MatchText ByteString] -> IO [[Identifier]]
f Int
_ ByteString
s [] = [[Identifier]] -> IO [[Identifier]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[ByteString -> Identifier
E.decodeUtf8 ByteString
s]]
f Int
i ByteString
s (MatchText ByteString
m:[MatchText ByteString]
mt) = do
Identifier
t <- [Identifier] -> IO Identifier
sub ([Identifier] -> IO Identifier) -> [Identifier] -> IO Identifier
forall a b. (a -> b) -> a -> b
$ MatchText ByteString -> [Identifier]
_rxMatches MatchText ByteString
m
([ByteString -> Identifier
E.decodeUtf8 ByteString
s1, Identifier
t][Identifier] -> [[Identifier]] -> [[Identifier]]
forall a. a -> [a] -> [a]
:) ([[Identifier]] -> [[Identifier]])
-> IO [[Identifier]] -> IO [[Identifier]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ByteString -> [MatchText ByteString] -> IO [[Identifier]]
f (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len) (Int -> ByteString -> ByteString
BL.drop Int
len ByteString
s2) [MatchText ByteString]
mt
where
(ByteString
s1, ByteString
s2) = Int -> ByteString -> (ByteString, ByteString)
BL.splitAt (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) ByteString
s
(Int
off, Int
len) = (Int -> Int
forall a. Enum a => Int -> a
toEnum (Int -> Int) -> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> Int
forall a. Enum a => Int -> a
toEnum) ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (ByteString, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd (MatchText ByteString
m MatchText ByteString -> Int -> (ByteString, (Int, Int))
forall i e. Ix i => Array i e -> i -> e
A.! Int
0)
_rxMatches :: RE.MatchText BL.ByteString -> [Text]
_rxMatches :: MatchText ByteString -> [Identifier]
_rxMatches = ((ByteString, (Int, Int)) -> Identifier)
-> [(ByteString, (Int, Int))] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Identifier
E.decodeUtf8 (ByteString -> Identifier)
-> ((ByteString, (Int, Int)) -> ByteString)
-> (ByteString, (Int, Int))
-> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, (Int, Int)) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, (Int, Int))] -> [Identifier])
-> (MatchText ByteString -> [(ByteString, (Int, Int))])
-> MatchText ByteString
-> [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchText ByteString -> [(ByteString, (Int, Int))]
forall i e. Array i e -> [e]
A.elems
par :: (Block -> Evaluator) -> Builtin
par :: (Block -> Evaluator) -> Builtin
par Block -> Evaluator
callBlock = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"par" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
((Block
f, Block
g), Stack
s') <- Stack -> IO ((Block, Block), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
(Stack
l1, Stack
l2) <- IO Stack -> IO Stack -> IO (Stack, Stack)
forall a b. IO a -> IO b -> IO (a, b)
concurrently (Block -> Evaluator
callBlock Block
f Context
c Stack
emptyStack)
(Block -> Evaluator
callBlock Block
g Context
c Stack
emptyStack)
Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
l2 Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ Stack
l1 Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ Stack
s')
sleep :: Builtin
sleep :: Builtin
sleep = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"sleep" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
(Either Integer Double
n, Stack
s') <- Stack -> IO (Either Integer Double, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
let ms :: Integer
ms = (Integer -> Integer)
-> (Double -> Integer) -> Either Integer Double -> Integer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*) (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Integer) -> (Double -> Double) -> Double -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double
1000 :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
*)) Either Integer Double
n
Stack
s' Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> IO ()
threadDelay (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ms)
version :: Builtin
version :: Builtin
version = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"version" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Stack -> IO Stack) -> Evaluator
forall a b. a -> b -> a
const ((Stack -> IO Stack) -> Evaluator)
-> (Stack -> IO Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Stack -> Stack -> IO Stack) -> Stack -> Stack -> IO Stack
forall a b c. (a -> b -> c) -> b -> a -> c
flip Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1
(Stack -> Stack -> IO Stack) -> Stack -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ [Stack -> KValue
forall a. ToVal a => [a] -> KValue
list (Stack -> KValue) -> Stack -> KValue
forall a b. (a -> b) -> a -> b
$ (Integer -> KValue) -> [Integer] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Integer -> KValue
int [Integer]
_koneko_version, Identifier -> KValue
kwd(Identifier
"hs"),
Stack -> KValue
forall a. ToVal a => [a] -> KValue
list (Stack -> KValue) -> Stack -> KValue
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
str [Identifier]
_platform]
_koneko_version :: [Integer]
_koneko_version :: [Integer]
_koneko_version = (Int -> Integer) -> [Int] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int] -> [Integer]) -> [Int] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
P.version
_platform :: [Text]
_platform :: [Identifier]
_platform = (String -> Identifier) -> [String] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map String -> Identifier
T.pack [String
I.os String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
I.arch, String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v]
where
c :: String
c = String
I.compilerName; v :: String
v = Version -> String
showVersion Version
I.compilerVersion
replDef :: Context -> IO ()
replDef :: Context -> IO ()
replDef Context
ctx = do
[Identifier] -> Maybe Identifier -> Identifier -> IO ()
alias [Identifier
"show-stack!" , Identifier
"s!"] Maybe Identifier
forall a. Maybe a
Nothing Identifier
primModule
[Identifier] -> Maybe Identifier -> Identifier -> IO ()
alias [Identifier
"clear-stack!", Identifier
"c!"] Maybe Identifier
forall a. Maybe a
Nothing Identifier
primModule
[Identifier] -> Maybe Identifier -> Identifier -> IO ()
alias [Identifier
"d!"] (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
"display!") Identifier
prldModule
[Identifier] -> Maybe Identifier -> Identifier -> IO ()
alias [Identifier
"D!"] (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
"ddisplay!") Identifier
prldModule
Context -> Identifier -> KValue -> IO ()
defineIn Context
ctx Identifier
"__repl__" KValue
true
where
alias :: [Identifier] -> Maybe Identifier -> Identifier -> IO ()
alias [Identifier]
new Maybe Identifier
old Identifier
m = do
KValue
x <- Context -> Identifier -> Identifier -> IO KValue
lookupModule' Context
ctx (Identifier
-> (Identifier -> Identifier) -> Maybe Identifier -> Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Identifier -> Identifier
underscored (Identifier -> Identifier) -> Identifier -> Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Identifier
forall a. [a] -> a
head [Identifier]
new) Identifier -> Identifier
forall a. a -> a
id Maybe Identifier
old) Identifier
m
(Identifier -> IO ()) -> [Identifier] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Identifier -> KValue -> IO ()) -> KValue -> Identifier -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Context -> Identifier -> KValue -> IO ()
defineIn Context
ctx) KValue
x) [Identifier]
new
showStack :: Evaluator -> Builtin
showStack :: Evaluator -> Builtin
showStack Evaluator
call = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"show-stack!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> Stack
s Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
KValue
p <- Context -> Identifier -> Identifier -> IO KValue
lookupModule' Context
c Identifier
"show" Identifier
prldModule
let f :: KValue -> IO ()
f KValue
x = (Identifier, Stack) -> Identifier
forall a b. (a, b) -> a
fst ((Identifier, Stack) -> Identifier)
-> IO (Identifier, Stack) -> IO Identifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stack -> IO (Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' (Stack -> IO (Identifier, Stack))
-> IO Stack -> IO (Identifier, Stack)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Evaluator
call Context
c [KValue
p, KValue
x]) IO Identifier -> (Identifier -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identifier -> IO ()
T.putStrLn
String -> IO ()
putStrLn String
"--- STACK ---"
(KValue -> IO ()) -> Stack -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ KValue -> IO ()
f Stack
s
String -> IO ()
putStrLn String
"--- END ---"
clearStack :: Builtin
clearStack :: Builtin
clearStack = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"clear-stack!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
_ ->
Stack
emptyStack Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Identifier -> IO ()
T.putStrLn Identifier
"*** STACK CLEARED ***"
nya :: Builtin
nya :: Builtin
nya = Identifier -> Evaluator -> Builtin
mkPrim Identifier
"nya!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> Stack
s Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
String
nyaD <- String -> IO String
P.getDataFileName String
"nya"
[String]
cats <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".cat") ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
nyaD
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cats) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int
i <- (StdGen -> (Int, StdGen)) -> IO Int
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom ((StdGen -> (Int, StdGen)) -> IO Int)
-> (StdGen -> (Int, StdGen)) -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cats Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
(String -> IO Identifier
T.readFile (String -> IO Identifier) -> String -> IO Identifier
forall a b. (a -> b) -> a -> b
$ String
nyaD String -> String -> String
</> ([String]
cats [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
i)) IO Identifier -> (Identifier -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identifier -> IO ()
T.putStr