module Bricks.BuiltinFunctions where
import Bricks.Term
import Bricks.Type
import Bricks.Internal.Prelude
import Bricks.Internal.Text (Text)
import qualified Bricks.Internal.Text as Text
import qualified Data.Map as Map
import Data.Set (Set)
import Data.Dynamic (fromDynamic, toDyn)
import Data.Typeable (Typeable)
import Prelude (Integer, Num (..))
import Text.Read (readMaybe)
term'data :: forall a. Typeable a => Type a -> a -> Term
term'data (Type n) = Term'Data n . toDyn @a
fn'pure'parametric'arity1 :: (Term -> Term) -> Term
fn'pure'parametric'arity1 f =
Term'Function $ \x -> pure $
f x
fn'pure'parametric'arity2 :: (Term -> Term -> Term) -> Term
fn'pure'parametric'arity2 f =
Term'Function $ \x -> pure $
fn'pure'parametric'arity1 $ f x
fn'pure'parametric'arity3 :: (Term -> Term -> Term -> Term) -> Term
fn'pure'parametric'arity3 f =
Term'Function $ \x -> pure $
fn'pure'parametric'arity2 $ f x
fn'id :: Term
fn'id = fn'pure'parametric'arity1 id
fn'const :: Term
fn'const = fn'pure'parametric'arity2 const
fn'comp :: Term
fn'comp = fn'pure'parametric'arity3 $ \f g x -> f /@\ (g /@\ x)
fn'flip :: Term
fn'flip = fn'pure'parametric'arity3 $ \f x y -> f /@@\ (y, x)
fn'dict'lookup :: Term
fn'dict'lookup =
Term'Function $ \x -> do
map <- reduce'dict'keys x
pure $ Term'Function $ \y -> do
key <- cast'data type'string y
case Map.lookup key map of
Nothing -> bottom . Bottom $ "Key " <> key <> " not found in dict"
Just a -> pure a
fn'or :: Term
fn'or =
Term'Function $ \x -> cast'data type'boolean x <&>
\case
True -> fn'const /@\ term'data type'boolean True
False -> assert'type type'boolean
fn'and :: Term
fn'and =
Term'Function $ \x -> cast'data type'boolean x <&>
\case
False -> fn'const /@\ term'data type'boolean False
True -> assert'type type'boolean
fn'string'append :: Term
fn'string'append =
Term'Function $ \x -> cast'data type'string x <&> \x' ->
Term'Function $ \y -> cast'data type'string y <&> \y' ->
term'data type'string (Text.append x' y')
fn'dict'disallowExtraKeys :: Set Text -> Term
fn'dict'disallowExtraKeys _allowedKeys =
Term'Function $ undefined
fn'dict'merge'preferLeft :: Term
fn'dict'merge'preferLeft =
Term'Function $ \x -> reduce'dict'keys x <&> \x' ->
Term'Function $ \y -> reduce'dict'keys y <&> \y' ->
Term'Dict'ReducedKeys $ Map.union x' y'
fn'dict'merge'preferRight :: Term
fn'dict'merge'preferRight = fn'flip /@\ fn'dict'merge'preferLeft
cast'data :: (MonadEval m, Typeable a) => Type a -> Term -> m a
cast'data = req fst
assert'type :: Typeable a => Type a -> Term
assert'type t = Term'Function $ req snd t
req :: forall a b m. (MonadEval m, Typeable a)
=> ((a, Term) -> b)
-> Type a
-> Term
-> m b
req s (Type n) = reduce'term >=> \case
t@(Term'Data n' x) ->
case fromDynamic @a x of
Nothing -> bottom . Bottom $ "Expected " <> n <> ", got " <> n'
Just a -> pure (s (a, t))
x ->
termTypeName x >>= \n' ->
bottom . Bottom $ "Expected " <> n <> ", got " <> n'
fn'int'add :: Term
fn'int'add =
Term'Function $ \x -> cast'data type'integer x <&> \x' ->
Term'Function $ \y -> cast'data type'integer y <&> \y' ->
term'data type'integer (x' + y')
fn'int'constructor :: Term
fn'int'constructor =
Term'Function $ cast'data type'string >=> (
Text.unpack >>> readMaybe @Integer >>>
maybe (bottom . Bottom $ "invalid integer")
(pure . term'data type'integer)
)
standard'library :: Term
standard'library =
Term'Dict'ReducedKeys . Map.fromList $
[ ("add", fn'int'add)
, ("integer", fn'int'constructor)
, ("and", fn'and)
, ("or", fn'or)
, ("id", fn'id)
, ("const", fn'const)
]