.gitignore

.stack-work

ChangeLog.md

Revision history for agony

0.1.0.0 -- YYYY-mm-dd

• First version. Released on an unsuspecting world.

Env.hs

module Env
  ( Env
  , empty
  , bind
  , fromList
  , add
  , lookup
  , keys
  , toLists
  ) where

import Prelude hiding (lookup)

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

import           Data.Monoid

newtype Env key value = Env
  { getEnv :: [Map key value] }
  deriving (Show)

empty :: Env key value
empty = Env []

lookup :: Ord key => Env key value -> key -> Maybe value
lookup (Env maps) key = getFirst (mconcat (map (First . Map.lookup key) maps))

bind :: Ord key => key -> value -> Env key value
bind k v = Env [Map.singleton k v]

add :: Ord key => Env key value -> Env key value -> Env key value
add (Env new) (Env base) = Env (new ++ base)

fromList :: Ord key => [(key, value)] -> Env key value
fromList pairs = Env [Map.fromList pairs]

keys :: Env key value -> [key]
keys (Env maps) = foldMap Map.keys maps

toLists :: Env key value -> [[(key, value)]]
toLists (Env map) = Prelude.map Map.toList map

instance Functor (Env key) where
  fmap f (Env map) = Env (fmap (fmap f) map)

Eval.hs

module Eval where

import           Data.Traversable (for)

import           Name (Name)
import qualified Name

import           Program
import           Runtime

import           Debug.Trace

import           Env (Env)
import qualified Env


apply :: Value -> M ()
apply value = case value of
  BIF     action            -> action
  Closed (_, (ctx, action)) -> withContext (\_ -> ctx) action
  other                     -> push [other]

letrec :: [Decl (Program Value)] -> M Context
letrec decls = do
    ctx <- context
    rec
      env <- declsToEnv decls (Env.add env ctx) ctx
    return env
  where
    declsToEnv :: [Decl (Program Value)] -> Context -> Context -> M Context
    declsToEnv decls ctx old = do
        pairs <- mapM asPair decls
        return (Env.fromList pairs)
      where
        asPair (Decl args name body) = do
            return (name, (Value value, apply value))
          where
            value = Closed (prog, (ctx, eval prog))
            prog  = Intro args body

        asPair (Capture name) = do
          let mbProg = Env.lookup old name
          case mbProg of
            Just (descr, prog) -> do
              return (name, (descr, apply (Closed (descr, (old, prog)))))

            Nothing -> do
              throwM (NameUndefined name)

runParallel :: [Program Value] -> M ()
runParallel progs = do
    stacks <- mapM collect progs
    mapM_ push stacks
  where
    collect :: Program Value -> M [Value]
    collect prog = do
      track (eval prog)

-------------------------------------------------------------------------------

eval :: Program Value -> M ()
eval prog = case prog of
  Call   name  -> call name
  Phase0 prog' -> eval prog'

  Intro names k -> do
    pairs <- for names $ \name -> do
      val <- pop
      return (name, (Value val, apply val))

    let env = Env.fromList pairs
    withContext (Env.add env) (eval k)

  Use names k -> do
    val <- pop
    case val of
      Module (oldCtx, decls) -> do
        let delta = Env.add decls oldCtx
        withContext (Env.add delta) (eval k)

  Let decls k -> do
    delta <- letrec decls
    withContext (Env.add delta) (eval k)

  Object decls -> do
    ctx   <- context
    delta <- letrec decls
    push [Module (ctx, delta)]

  Seq progs -> do
    mapM_ eval progs

  Par progs -> do
    runParallel progs

  Quote prog -> do
    ctx <- context
    case prog of
      Call name -> do
        case Env.lookup ctx name of
          Just (Value (v@Closed {}), _) ->
            push [Closed (prog, (ctx, eval prog))]

          Just (Value (v@BIF {}), _) ->
            push [Closed (prog, (ctx, eval prog))]

          Just (Value v, _) -> do
            push [v]

      _ -> do
        push [Closed (prog, (ctx, eval prog))]

  Str s -> push [String s]
  Num n -> push [Number n]

LICENSE

Copyright (c) 2019, Kirill Andreev

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Kirill Andreev nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Main.hs

{-# language OverloadedLists #-}
{-# language OverloadedStrings #-}
{-# language OverloadedLabels #-}

module Main where

import Program
import Eval
import Runtime
import Stdlib
import Stack

test =
  Let
    [ Decl [#a, #b] #sip [Quote #b, #a, Quote #b]
    ]
  [ 1
  , 2
  , Intro [#a, #b]
    [ #a
    , "a"
    , #b
    , "b"
    ]
  ]

main = runM (eval test) stdlib Stack.empty

Name.hs

{-# language MagicHash #-}

module Name where

import Data.Function (on)
import Data.String (IsString (..))
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits (KnownSymbol, symbolVal')
import GHC.Exts (Proxy#, proxy#)

data Name = Name
  { raw        :: String
  , col        :: Int
  , pos        :: Int
  , sourceFile :: String
  }

elaborated :: Name -> String
elaborated (Name raw col pos src) =
  mconcat [raw, "@", show src, ":", show col, ":", show pos]

instance Show Name where
  show = raw

instance Ord Name where
  compare = compare `on` raw

instance Eq Name where
  (==) = (==) `on` raw

internal :: String -> Name
internal raw = Name raw (-1) (-1) "internal"

s :: String -> Name
s raw = Name raw 12 34 "source.joy"

instance KnownSymbol sym => IsLabel sym Name where
  fromLabel = s (symbolVal' (proxy# :: Proxy# sym))

package.yaml

name: agony

default-extensions:
- FlexibleInstances
- BlockArguments
- RecursiveDo
- TypeFamilies
- MultiParamTypeClasses
- TypeApplications
- ScopedTypeVariables

dependencies:
- base
- containers

executables:
  agony:
    main: Main.hs

Program.hs

module Program where

import           Data.List   (intercalate)
import           Name        (Name)
import           Data.String (IsString (..))
import           GHC.Exts    (IsList (..))
import           GHC.OverloadedLabels (IsLabel (..))
import           GHC.TypeLits (KnownSymbol)


data Program v
  = Call     Name                           -- call of function or "variable"
  | Phase0   (Program v)                    -- = C++ constexpr
  | Intro   [Name]             (Program v)  -- pop thing from stack, give it a name
  | Use     [Name]             (Program v)  -- pop thing from stack, deconstruct to names
  | Let     [Decl (Program v)] (Program v)  -- add local definitions
  | Object  [Decl (Program v)]              -- a bunch of definitions
  | Seq     [Program v]                     -- run stuff sequentally   (composition)
  | Par     [Program v]                     -- run stuff "in parallel" (also composition)
  | Quote   (Program v)                     -- = a ruby block
  | Str      String
  | Num      Double
  | Value    v

data Decl body
  = Decl
    { args :: [Name]
    , name ::  Name
    , body ::  body
    }

  | Capture { name :: Name }

instance Show value => Show (Program value) where
  show prog = case prog of
    Call    name     -> show name
    Phase0  prog     -> "$(" ++ show prog ++ ")"
    Intro   names k  -> "\\"   ++ unwords          (map show names) ++ ". "   ++ show k
    Use     names k  -> "use " ++ unwords          (map show names) ++ " in " ++ show k
    Let     decls k  -> "let " ++ intercalate "; " (map show decls) ++ " in " ++ show k
    Object  decls    -> "{"    ++ intercalate "; " (map show decls) ++ "}"
    Seq     progs    ->           unwords          (map show progs)
    Par     progs    ->           intercalate "|"  (map show progs)
    Quote   (Call n) -> ":"    ++ show n
    Quote   (Seq s)  -> "["    ++ unwords          (map show s)     ++ "]"
    Quote   prog     -> "["    ++ show prog ++ "]"
    Str     s        -> show s
    Num     n        -> show n
    Value   v        -> show v

instance Show value => Show (Decl (Program value)) where
  show (Decl args name (Seq body)) =
    unwords (map (show . (:[])) args) ++ " " ++ show name ++ " = " ++ unwords (map show body)

  show (Decl args name body) =
    unwords (map (show . (:[])) args) ++ " " ++ show name ++ " = " ++ show body

  show (Capture name) = show name

instance IsString (Program value) where
  fromString = Str

instance Num (Program value) where
  fromInteger = Num . fromInteger

instance KnownSymbol sym => IsLabel sym (Program value) where
  fromLabel = Call (fromLabel @sym)

instance IsList (Program value) where
  type Item (Program value) = Program value
  fromList = Seq
  toList = error "IsList(Program).toList: nope"

Runtime.hs

module Runtime where

import           Control.Exception
import           Control.Monad (ap, liftM)
import           Control.Monad.Fix

import           Env (Env)
import qualified Env

import           Stack (Stack)
import qualified Stack

import           Name (Name)
import qualified Name

import           Program

type Closure a   = (Context, a)
type Context     = Env Name (Program Value, M ())

newtype M a = M { runM :: Context -> Stack Value -> IO (a, Stack Value) }

type M_ = M ()

data Value
  = BIF     M_                         -- builtin function
  | String  String
  | Number  Double
  | Closed (Program Value, Closure M_) -- a program, closed under context
  | Module (Closure Context)           -- an object, closed under context

throwM :: Exception e => e -> M a
throwM e = M (\_ _ -> throwIO e)

context :: M Context
context = M (\ctx stack -> return (ctx, stack))

withContext :: (Context -> Context) -> M a -> M a
withContext f m = M (\ctx stack -> runM m (f ctx) stack)

push :: [Value] -> M ()
push vals = M (\_ stack -> return ((), Stack.pushAll vals stack))

data NameUndefined = NameUndefined Name
  deriving (Show)

instance Exception NameUndefined

data StackUnderflow = StackUnderflow
  deriving (Show)

instance Exception StackUnderflow

pop :: M Value
pop =
  M (\_ stack ->
    case Stack.pop stack of
      Just (val, stack') -> return (val, stack')
      Nothing            -> throwIO Underflow
  )

track :: M () -> M [Value]
track m =
  M (\ctx stack -> do
    ((), stack') <- runM m ctx stack
    let (before, after) = Stack.diff stack stack'
    return (before, after)
  )

call :: Name -> M ()
call name =
  M (\ctx stack -> do
    let val = Env.lookup ctx name
    case val of
      Just (_, action) -> runM action ctx stack
      Nothing          -> throwIO (NameUndefined name)
  )

instance Functor M where
  fmap = liftM

instance Applicative M where
  pure a = M (\_ stack -> pure (a, stack))
  (<*>)  = ap

instance Monad M where
  m >>= callb =
    M (\ctx stack -> do
      (a, stack') <- runM m ctx stack
      runM (callb a) ctx stack'
    )

instance MonadFix M where
  mfix f =
    M (\ctx stack -> do
      rec (a, stack') <- runM (f a) ctx stack
      return (a, stack')
    )

instance Show Value where
  show val = case val of
    BIF    _ -> "#"
    Number n -> show n
    String s -> show s
    Closed (descr, _) -> "[" ++ show descr ++ "]"
    Module (ctx, stuff) -> "{" ++ unwords (map show (Env.keys stuff)) ++ "}"

Setup.hs

import Distribution.Simple
main = defaultMain

Stack.hs

module Stack
  ( Stack
  , push
  , pushAll
  , empty
  , pop
  , toList
  , fromList
  , diff
  )
  where

import Data.List (unfoldr)

-- We cannot use `[a]` for our definitional interpreter, because our
-- "parallel" composition requires us to know, how much stack was used.
data Stack a
  = Push Int a (Stack a)
  | Empty

empty :: Stack a
empty = Empty

push :: a -> Stack a -> Stack a
push a stack = Push (lastIndex stack + 1) a stack

pushAll :: [a] -> Stack a -> Stack a
pushAll vals stack = foldr push stack vals

fromList :: [a] -> Stack a
fromList = foldr push Empty

lastIndex :: Stack a -> Int
lastIndex (Push i _ _) = i
lastIndex  Empty       = 0

pop :: Stack a -> Maybe (a, Stack a)
pop (Push _ a rest) = Just (a, rest)
pop  Empty          = Nothing

-- `diff s t`, if `t` is made from `s` via `push` and `pop`, will return all added elements
diff :: Stack a -> Stack a -> ([a], Stack a)
diff s (Push i a rest)
  | i > lastIndex s =
    (a : before, after)
      where
        (before, after) = diff s rest
diff _ t = ([], t)

toList :: Stack a -> [a]
toList = unfoldr pop

instance Show a => Show (Stack a) where
  show = unwords . map show . toList

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

# 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

Stdlib.hs

module Stdlib where

import Data.Foldable

import Eval
import Runtime
import Program
import Name
import Env


func :: String -> M_ -> (Name, (Program Value, M_))
func name action = (Name.internal name, (Value (BIF action), action))

stdlib :: Context
stdlib = Env.fromList
  [ func "i" do
      i <- pop
      apply i

  , func "dip" do
      a <- pop
      b <- pop
      apply a
      push [b]

  , func "swap" do
      a <- pop
      b <- pop
      push [a]
      push [b]

  , func "dup" do
      a <- pop
      push [a, a]

  , func "drop" do
      _ <- pop
      return ()

  , func "cat" do
      a <- pop
      b <- pop
      ctx <- context
      let
        val =
          Closed (Seq [Value b, Value a], (ctx, do
            apply b
            apply a
          ))
      push [val]

  , func "cons" do
      a <- pop
      b <- pop
      ctx <- context
      let
        val =
          Closed (Seq [Quote (Value b), Value a], (ctx, do
            push [b]
            apply a
          ))
      push [val]

  , func "unit" do
      a <- pop
      ctx <- context
      let
        val =
          Closed (Value a, (ctx, do
            push [a]
          ))
      push [val]

  , func "_" dump
  ]

dump :: M ()
dump = M $ \ctx stack -> do
  putStrLn "== Names ===="
  for_ (reverse (Env.toLists ctx)) $ \list -> do
    putStrLn "{"

    let maxlen = maximum $ flip map list $ \(key, (descr, _)) -> length (show key ++ show descr)

    for_ list $ \(key, (descr, _)) -> do
      let postIndent = maxlen - length (show key ++ show descr)
      putStrLn ("  " ++ show key ++ ":" ++ show descr ++ ";" ++ replicate postIndent ' ' ++ " -- " ++ elaborated key)

    putStrLn "}"

  putStrLn "== Data ===="
  putStrLn ("> " ++ show stack)
  putStrLn ""

  return ((), stack)