--  --                                                          ; {{{1
--
--  File        : Koneko/Bltn.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 OverloadedStrings #-}

module Koneko.Bltn (initCtx) where

import Data.Foldable (traverse_)
import Data.Maybe (fromJust) -- careful!

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

import qualified Data.HashMap.Strict as H

import Koneko.Data
import Koneko.Misc (pInt, pFloat, parseMaybe)
import Koneko.Prim (swap)

initCtx :: Context -> Evaluator -> IO ()
initCtx :: Context -> Evaluator -> IO ()
initCtx Context
ctxMain Evaluator
call = do
  Context
ctx <- Identifier -> Context -> IO Context
forkContext Identifier
bltnModule 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) ([Builtin] -> IO ()) -> [Builtin] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Builtin]
typePreds [Builtin] -> [Builtin] -> [Builtin]
forall a. [a] -> [a] -> [a]
++ [
      Builtin
strToInt, Builtin
strToFloat,
      Builtin
dup, Builtin
drop_, Identifier -> Evaluator -> Builtin
mkBltn Identifier
"swap" (Builtin -> Evaluator
biRun Builtin
swap), Evaluator -> Builtin
dip Evaluator
call,
      Builtin
dollar, Builtin
at, Builtin
percent,
      Evaluator -> Builtin
br_pred Evaluator
call, Evaluator -> Builtin
br_nil Evaluator
call
    ]

typePreds :: [Builtin]
typePreds :: [Builtin]
typePreds = [ Identifier -> Evaluator -> Builtin
mkBltn (Identifier
x Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"?") (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) -> Evaluator) -> (KValue -> Bool) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
x) (Identifier -> Bool) -> (KValue -> Identifier) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KType -> Identifier
forall a. IsString a => KType -> a
typeToStr (KType -> Identifier) -> (KValue -> KType) -> KValue -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf | Identifier
x <- [Identifier]
typeNames ]

strToInt, strToFloat :: Builtin
strToInt :: Builtin
strToInt    = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"str->int"   (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Identifier -> Maybe Integer) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Identifier -> Maybe Integer) -> Evaluator)
-> (Identifier -> Maybe Integer) -> Evaluator
forall a b. (a -> b) -> a -> b
$ Parsec Void Identifier Integer -> Identifier -> Maybe Integer
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe Parsec Void Identifier Integer
pInt
strToFloat :: Builtin
strToFloat  = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"str->float" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Identifier -> Maybe Double) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Identifier -> Maybe Double) -> Evaluator)
-> (Identifier -> Maybe Double) -> Evaluator
forall a b. (a -> b) -> a -> b
$ Parsec Void Identifier Double -> Identifier -> Maybe Double
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe Parsec Void Identifier Double
pFloat

dup, drop_ :: Builtin
dup :: Builtin
dup   = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"dup"  (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> Stack -> KValue -> Stack
push' Stack
s (KValue -> Stack)
-> ((KValue, Stack) -> KValue) -> (KValue, Stack) -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KValue, Stack) -> KValue
forall a b. (a, b) -> a
fst ((KValue, Stack) -> Stack) -> IO (KValue, Stack) -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> IO (KValue, Stack)
pop_' Stack
s
drop_ :: Builtin
drop_ = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"drop" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> (KValue, Stack) -> Stack
forall a b. (a, b) -> b
snd ((KValue, Stack) -> Stack) -> IO (KValue, Stack) -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> IO (KValue, Stack)
pop_' Stack
s

dip :: Evaluator -> Builtin
dip :: Evaluator -> Builtin
dip Evaluator
call = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"dip" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
  ((KValue
x, KValue
f), Stack
s') <- Stack -> IO ((KValue, KValue), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
  (Stack -> KValue -> IO Stack) -> KValue -> Stack -> IO Stack
forall a b c. (a -> b -> c) -> b -> a -> c
flip Stack -> KValue -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 (KValue
x :: KValue) (Stack -> IO Stack) -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Evaluator
call Context
c (Stack -> KValue -> Stack
push' Stack
s' KValue
f)

dollar, at, percent :: Builtin
dollar :: Builtin
dollar  = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"$" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> KValue) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 KValue -> KValue -> KValue
partial
at :: Builtin
at      = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"@" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> KValue) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 KValue -> KValue -> KValue
compose
percent :: Builtin
percent = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"%" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> KValue) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 ((KValue -> KValue -> KValue) -> Evaluator)
-> (KValue -> KValue -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (KValue -> KValue -> KValue) -> KValue -> KValue -> KValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip KValue -> KValue -> KValue
compose

compose, partial :: KValue -> KValue -> KValue
compose :: KValue -> KValue -> KValue
compose KValue
f KValue
g = [Ident] -> Stack -> Maybe Scope -> KValue
block [] [Ident -> KValue
KIdent (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"f", Ident -> KValue
KIdent (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"g"]
            (Maybe Scope -> KValue) -> Maybe Scope -> KValue
forall a b. (a -> b) -> a -> b
$ [(Identifier, KValue)] -> Maybe Scope
_sc [(Identifier
"f", KValue
f), (Identifier
"g", KValue
g), (Identifier
"name", Ident -> KValue
KIdent (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"@")]
partial :: KValue -> KValue -> KValue
partial KValue
x KValue
f = [Ident] -> Stack -> Maybe Scope -> KValue
block [] [Ident -> KValue
KQuot (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"_x", Ident -> KValue
KIdent (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"f"]
            (Maybe Scope -> KValue) -> Maybe Scope -> KValue
forall a b. (a -> b) -> a -> b
$ [(Identifier, KValue)] -> Maybe Scope
_sc [(Identifier
"_x", KValue
x), (Identifier
"f", KValue
f), (Identifier
"name", Ident -> KValue
KIdent (Ident -> KValue) -> Ident -> KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
_ID Identifier
"$")]

-- UNSAFE!
_ID :: Identifier -> Ident
_ID :: Identifier -> Ident
_ID = Maybe Ident -> Ident
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Ident -> Ident)
-> (Identifier -> Maybe Ident) -> Identifier -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Maybe Ident
ident

_sc :: [(Identifier, KValue)] -> Maybe Scope
_sc :: [(Identifier, KValue)] -> Maybe Scope
_sc = Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope)
-> ([(Identifier, KValue)] -> Scope)
-> [(Identifier, KValue)]
-> Maybe Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ScopeLookupTable -> Scope
Scope Identifier
bltnModule (ScopeLookupTable -> Scope)
-> ([(Identifier, KValue)] -> ScopeLookupTable)
-> [(Identifier, KValue)]
-> Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Identifier, KValue)] -> ScopeLookupTable
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList

br_pred, br_nil :: Evaluator -> Builtin

br_pred :: Evaluator -> Builtin
br_pred Evaluator
call = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"~?" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s0 -> do
  ((KValue
x, KValue
f, KValue
g, KValue
p), Stack
s1) <- Stack -> IO ((KValue, KValue, KValue, KValue), Stack)
forall a b c d.
(FromVal a, FromVal b, FromVal c, FromVal d) =>
Stack -> IO ((a, b, c, d), Stack)
pop4' Stack
s0
  Stack
s2 <- Evaluator
call Context
c (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ (Stack -> KValue -> Stack) -> Stack -> Stack -> Stack
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Stack -> KValue -> Stack
push' Stack
s1 [KValue
x, KValue
x, KValue
p]
  (KValue
b, Stack
s3) <- Stack -> IO (KValue, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s2
  Evaluator
call Context
c (Stack -> IO Stack) -> Stack -> IO Stack
forall a b. (a -> b) -> a -> b
$ Stack -> KValue -> Stack
push' Stack
s3 (KValue -> Stack) -> KValue -> Stack
forall a b. (a -> b) -> a -> b
$ if KValue -> Bool
truthy KValue
b then KValue
f else KValue
g

br_nil :: Evaluator -> Builtin
br_nil Evaluator
call = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"~nil" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
c Stack
s -> do
  ((KValue
x, KValue
f, KValue
g), 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) -> Stack -> Stack -> Stack
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Stack -> KValue -> Stack
push' Stack
s' (Stack -> Stack) -> Stack -> Stack
forall a b. (a -> b) -> a -> b
$ if KValue -> Bool
isNil KValue
x then [KValue
f] else [KValue
x, KValue
g]

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