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

{-# LANGUAGE CPP #-}
{-# LANGUAGE 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

-- TODO
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
    ]

-- primitives: important --

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

-- TODO
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)

-- needed as primitive by read for .foo
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]

-- primitives: show, I/O & types --

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)

-- NB: uses stdio
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

-- NB: uses stdio
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

-- primitives: modules --

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

-- primitives: Eq, Ord --

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

-- primitives: arithmetic --

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 ))

-- primitives: conversion --

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

-- primitives: record --

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

-- primitives: record-type info --

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

-- primitives: thunk --

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   -- safe!
  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

-- primitives: exceptions --

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]                -- NB: reverse order
_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]

-- primitives: homoiconicity --

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

-- NB: must use existing block to provide Scope
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"

-- primitives: regex --

-- TODO
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

-- TODO
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)

-- TODO
_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
    -- NB: read & !! are safe!
    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)     -- safe!

_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

-- primitives: concurrency --

-- TODO
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)

-- primitives: miscellaneous --

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

-- repl --

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                            -- safe!
      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

-- TODO
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 --

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

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