An implementation of Joy language

Eval.hs

module Eval where

import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Catch

import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.Foldable

import Types

type MonadEval m = (MonadReader Names m, MonadState [Value] m, MonadCatch m)

eval :: forall m. MonadEval m => Program -> m ()
eval prog =
  case prog of
    New frame -> do
      names <- ask
      let frame' = fmap (Closed (frame' : names)) frame
      push (Object frame')

    Capture name prog -> do
      value <- pop
      local (Map.singleton name value :) $ do
        eval prog

    Call name -> do
      names <- ask
      case locateVar name names of
        Nothing -> do
          dump ("undefined " ++ show name)

        Just value -> do
          apply value

    Lambda prog -> do
      names <- ask
      push (Closed names prog)

    Seq progs -> do
      for_ progs eval

    Push c -> do
      push (Constant c)

    Let frame prog -> do
      names <- ask
      let frame' = fmap (Closed (frame' : names)) frame
      local (frame' :) $ do
        eval prog

  where
    dump reason = do
      names <- ask
      stack <- get
      throwM $ Dump reason names prog stack

    apply :: Value -> m ()
    apply (Closed names prog) = do
      local (const names) $ do
        eval prog

    apply (BIF f) = do
      modify f

    apply other = do
      push other

    pop = do
      stack <- get
      case stack of
        top : rest -> do
          put rest
          return top

        [] -> do
          dump "Stack is empty"

    push x = modify (x :)

locateVar :: Name -> Names -> Maybe Value
locateVar name (top : rest)
  | Just it <- Map.lookup name top = Just it
  | otherwise                      = locateVar name rest
locateVar name []                  = Nothing

test = Let
  (Map.fromList
    [ ("swap", Capture "x" $ Capture "y" $ Seq [Call "x", Call "y"])
    ]
  )
  (Seq [Call "swap"])

runEval :: Names -> (forall m. MonadEval m => m a) -> [Value] -> IO (a, [Value])
runEval names ma stack = do
  runReaderT (runStateT ma stack) names

package.yaml

dependencies:
- base
- exceptions
- containers
- mtl
- pretty

default-extensions:
- ConstraintKinds
- DeriveAnyClass
- DerivingStrategies
- DerivingVia
- FlexibleContexts
- OverloadedStrings
- RankNTypes
- ScopedTypeVariables

library:
  source-dirs: .
  exposed-modules:
  - Eval
  - Types

stack.yaml

# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/

# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-13.29

# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
#    git: https://github.com/commercialhaskell/stack.git
#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#  subdirs:
#  - auto-update
#  - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
# extra-deps: []

# Override default flag values for local packages and extra-deps
# flags: {}

# Extra package databases containing global packages
# extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.9"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

Types.hs

module Types where

import Control.Monad.Catch

import Data.Map (Map, (!))
import qualified Data.Map as Map

import Text.PrettyPrint hiding ((<>))

data Program
  = New      (Map Name Program)
  | Capture  Name Program
  | Call     Name
  | Lambda   Program
  | Seq      [Program]
  -- | Par [Program]
  | Push     Constant
  | Let      (Map Name Program) Program
  deriving Show via ShowAsDoc Program

data Value
  = Closed    Names Program
  | Object    Frame
  | Constant  Constant
  | BIF       (Stack -> Stack)
  deriving Show via ShowAsDoc Value

data Constant
  = Integer  Integer
  | Float    Double
  | String   String
  deriving Show via ShowAsDoc Constant

type Frame = Map Name Value
type Stack = [Value]
type Names = [Map Name Value]
type Name  = String

class Pretty p where
  pretty :: p -> Doc

instance Pretty Program where
  pretty (New     frame)  = pretty (Object $ fmap (Closed []) frame)
  pretty (Capture n prog) = "(\\" <> text n <> ". " <> pretty prog <> ")"
  pretty (Call    n)      = text n
  pretty (Lambda  prog)   = "[" <> pretty prog <> "]"
  pretty (Seq     prog)   = "(" <> fsep (map pretty prog) <> ")"
  pretty (Push    c)      = pretty c
  pretty (Let     ctx p)  = "(let " <> fsep (map text (Map.keys ctx)) <> " in " <> pretty p <> ")"

instance Pretty Value where
  pretty (Closed _ prog) = "[" <> pretty prog <> "]"
  pretty (Object frame)  = "[" <> fsep (map text (Map.keys frame)) <> "]"
  pretty (Constant c)    = pretty c
  pretty (BIF _)         = "<BIF>"

instance Pretty Constant where
  pretty (Integer i) = text $ show i
  pretty (Float   f) = text $ show f
  pretty (String  s) = text $ show s

newtype ShowAsDoc a = ShowAsDoc { unShowAsDoc :: a }

instance Pretty a => Show (ShowAsDoc a) where
  show = show . pretty . unShowAsDoc

data Dump = Dump
  { reason  :: String
  , names   :: Names
  , program :: Program
  , stack   :: [Value]
  }
  deriving Show via ShowAsDoc Dump
  deriving anyclass Exception

instance Pretty Dump where
  pretty (Dump reason names program stack) =
    hang "VM state dump:" 2 $ vcat
      [ hang "Reason:   " 2 $ text reason
      , hang "Caprures: " 2 $
        fsep $ map text $ Map.keys =<< names
      , hang "Data:     " 2 $ "[" <> fsep (map pretty stack) <> "]"
      , hang "Program:  " 2 $ pretty program
      ]