module Bricks.Term where
import Bricks.Internal.Monad
import Bricks.Internal.Prelude
import Bricks.Internal.Seq (Seq)
import Bricks.Internal.Text (Text)
import Data.Map (Map)
import Data.Set (Set)
import Data.Dynamic (Dynamic)
import Data.IORef
data Bottom = Bottom Text
displayBottom :: Bottom -> Text
displayBottom (Bottom message) = "Error: " <> message
class (Monad m, MonadIO m, MonadError Bottom m) => MonadEval m
where
reduce'term :: Term -> m Term
reduce'dict'keys :: Term -> m (Map Text Term)
type Function = forall m. MonadEval m => Term -> m Term
data Term
= Term'Data Text Dynamic
| Term'Function Function
| Term'Lambda TermPattern Term
| Term'LetRec (Map Text Term) Term
| Term'List (Seq Term)
| Term'Dict (Seq (Term, Term))
| Term'Dict'ReducedKeys (Map Text Term)
| Term'Var Text
| Term'Apply Term Term
| Term'Pointer TermPtr
(/@\) :: Term -> Term -> Term
(/@\) = Term'Apply
infixl /@\
(/@@\) :: Term -> (Term, Term) -> Term
f /@@\ (x, y) = (f /@\ x) /@\ y
infixl /@@\
(|->) :: TermPattern -> Term -> Term
(|->) = Term'Lambda
infixl |->
data TermPattern
= TermPattern'Simple Text
| TermPattern'Dict (Set Text)
type TermPtr = IORef Term
create'pointer :: MonadIO m => Term -> m Term
create'pointer x = case x of
Term'Pointer _ -> pure x
_ -> Term'Pointer <$> liftIO (newIORef x)
dereference :: MonadIO m => Term -> m Term
dereference = \case
Term'Pointer p -> readTermPtr p >>= dereference
x -> pure x
newTermPtr :: MonadIO m => Term -> m Term
newTermPtr x = case x of
Term'Pointer _ -> pure x
_ -> Term'Pointer <$> liftIO (newIORef x)
readTermPtr :: MonadIO m => TermPtr -> m Term
readTermPtr = liftIO . readIORef
writeTermPtr :: MonadIO m => TermPtr -> Term -> m ()
writeTermPtr ptr val = do
x <- dereference val
liftIO $ writeIORef ptr x
bottom :: MonadError Bottom m => Bottom -> m a
bottom = throwError