Lexically (and hyper-statically) scoped concatenative language

Eval.hs

{-# LANGUAGE FlexibleContexts #-}

module Eval
  ( EvalError (..)
  , eval
  , letrec
  ) where

import Control.Monad.Catch (Exception)

import Data.Foldable (for_)
import Data.Traversable (for)
import Data.Monoid ((<>))

import Scope
import Program
import VM

data EvalError
  = ExpectedLambda
  | ExpectedObject
  deriving Show

instance Exception EvalError

-- | Evaluate program.
eval :: VM c m => Program c -> m ()
eval (Fix instr) = case instr of
  Var name -> do
    code <- searchVia getScope name
    eval code

  Bif name -> do
    bif <- searchVia getBuiltins name
    runBIF bif

  Push v -> do
    push v

  Lambda self -> do
    ctx <- getScope
    push $ Closed $ Closure ctx self

  Seq instrs -> do
    for_ instrs eval

  Par instrs -> do
    backtrace <- for instr $ \i -> do
      produced (eval i)

    for_ backtrace $ \stack -> do
      for stack $ \item -> do
        push item

  Create (Object ctx names) -> do
    vals <- pops (length names)
    let methods   = map (Fix . Push) vals
    let preObject = fromList (zip names methods) <> ctx
    push $ Module $ letrec preObject

  Let body -> do
    ctx <- popThe _Module
    withLocalDefs ctx $ do
      eval body

  Exec -> do
    clos <- popThe _Closed
    eval $ Fix $ Open clos

  Open (Closure ctx body) -> do
    withScope ctx $ do
      eval body

-- | Turn scope into mutually-recursive one.
letrec :: Scope (Program c) -> Scope (Program c)
letrec ctx = result
  where
    result = Fix . Open . Closure result <$> ctx

Main.hs

import Parser
import VM
import Eval
import PP

main = do
  mprog <- parseFromFile (program unit) "test.rscl"
  either (error . show) (print . pretty) mprog

Name.hs

module Name where

type Name = String

Parser.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Parser
  ( parseFromFile
  , parse
  , program
  , unit
  ) where

import Control.Applicative (some)
import Control.Monad (guard)
import Text.ParserCombinators.Parsec hiding (token)

import Program
import Name
import qualified Scope

program :: Parser c -> Parser (Program c)
program constant = spaces >> Fix . Seq <$> many (theProgram constant)

theProgram :: forall c.  Parser c -> Parser (Program c)
theProgram constant = self
  where
    self :: Parser (Program c)
    self = Fix <$>
      (   var
      <|> bif
      <|> push
      <|> lam
      <|> seq_
      <|> create
      <|> let_
      <|> exec
      )
      where
        var    =             Var <$> name
        bif    = char '#' >> Bif <$> name
        push   =    Push . Const <$> constant
        lam    = token "[" >> Lambda <$> program constant <* token "]"
        seq_   = token "(" >> (Par <$> sepBy (program constant) (token "|")) <* token ")"
        create = token "{" >> objectDef <* token "}"
          where
            objectDef = do
              defs <- many fieldDef
              let kvs   = [(k, v) | Right (k, v) <- defs]
              let names = [ name  | Left   name  <- defs]
              return $ Create $ Object (Scope.fromList kvs) names
              where
                fieldDef = do
                  k <- name
                  field k <|> capture k
                  where
                    field k = do
                      token ":"
                      v <- program constant
                      token ";"
                      return $ Right (k, v)

                    capture k = do
                      token ","
                      return $ Left k
        let_ = do
          token "=>"
          p <- program constant
          return (Let p)

        exec = do
          token "@"
          return Exec

        name = try $ do
          raw <- some $ noneOf " \n\t[]{}()|:#,;"
          guard (raw `notElem` words "@ =>")
          spaces
          return raw

unit :: Parser ()
unit = token "1"

token s = try (string s) >> spaces

fix f = x where x = f x

PP.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module PP (Pretty (..)) where

import Data.Functor.Foldable
import Text.PrettyPrint

import Program
import Scope

class Pretty p where
  pretty :: p -> Doc

instance Pretty String where
  pretty = text

instance Pretty c => Pretty (Program c) where
  pretty = cata $ \case
    Var name -> pretty name
    Bif name -> "#" <> pretty name
    Push (Const v) -> pretty v
    Push (Closed (Closure _ i)) -> inside "[]" i
    Lambda i -> inside "[]" i
    Seq is   -> fsep is
    Par is   -> inside "()" $ fsep (punctuate " |" is)
    Create o -> pretty o
    Let i    -> "=>" <+> i
    Exec     -> "@"

instance Pretty (Object Doc) where
  pretty (Object methods names) =
    inside "{}"
      $  fsep (((<> ",") . pretty) `map` names)
      $$ vcat (uncurry (def ":;")  `map` toList methods)

instance Pretty () where
  pretty () = "1"

inside [l, r] i = hang (hang (text [l]) 2 i) 0 (text [r])

def [eq, end] k v = hang (hang (pretty k <> text [eq]) 2 v) 2 (text [end])

-- type Program c = Fix (Program_ c)

-- -- | Type for RASCaL program.
-- data Program_ c self
--   = Var     Name           -- ^ foo
--   | Bif     Name           -- ^ #foo           - builtin function
--   | Push   (Value c self)  -- ^ 123
--   | Lambda  self           -- ^ [foo bar]      - scope is closed on evaluation
--   | Seq    [self]          -- ^ (foo bar)      - sequence of instructions
--   | Par    [self]          -- ^ (foo | bar)    - "parallel" evaluation
--   | Create (Object self)   -- ^ { a, b: bar }  - scope is closed, mutual rec
--   | Let     self           -- ^ open foo bar   - opens object from stack for use
--   | Exec                   -- ^ @              - evaluate lambda on stack
--   | Open   (Closure self)  -- ^ -              - evaluate given lambda
--   deriving (Eq, Show, Functor, Foldable, Traversable)

-- -- | Builtin function. Provides side-effect only.
-- newtype BIF m = BIF { runBIF :: m () }

-- -- | Type for RASCaL value (extends type c).
-- data Value c ast
--   = Const   c             -- ^ Plain old constant of type "c"
--   | Closed (Closure ast)  -- ^ Evaluated function, carries its scope
--   | Module (Scope   ast)  -- ^ Evaluated object
--   deriving (Eq, Show, Functor, Foldable, Traversable)

-- -- | Representation for closure
-- data Closure ast = Closure
--   { closScope :: Scope ast  -- ^ Captured scope
--   , closBody  :: ast        -- ^ Body of function
--   }
--   deriving (Eq, Show, Functor, Foldable, Traversable)

-- -- | Request to create an object
-- data Object ast = Object
--   { oMethods ::  Scope ast  -- Methods
--   , oCapture :: [Name]      -- Values to capture from stack
--   }
--   deriving (Eq, Show, Functor, Foldable, Traversable)

-- makePrisms ''Value

Program.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TemplateHaskell #-}

module Program
  ( Program
  , Program_ (..)
  , Fix (..)
  , BIF (..)
  , Value (..)
  , Closure (..)
  , Object (..)
  , _Const
  , _Closed
  , _Module
  ) where

import Data.Functor.Foldable (Fix (..))

import Control.Lens (makePrisms)

import Scope
import Name

type Program c = Fix (Program_ c)

-- | Type for RASCaL program.
data Program_ c self
  = Var     Name           -- ^ foo
  | Bif     Name           -- ^ #foo           - builtin function
  | Push   (Value c self)  -- ^ 123
  | Lambda  self           -- ^ [foo bar]      - scope is closed on evaluation
  | Seq    [self]          -- ^ (foo bar)      - sequence of instructions
  | Par    [self]          -- ^ (foo | bar)    - "parallel" evaluation
  | Create (Object self)   -- ^ { a, b: bar }  - scope is closed, mutual rec
  | Let     self           -- ^ open foo bar   - opens object from stack for use
  | Exec                   -- ^ @              - evaluate lambda on stack
  | Open   (Closure self)  -- ^ -              - evaluate given lambda
  deriving (Eq, Show, Functor, Foldable, Traversable)

-- | Builtin function. Provides side-effect only.
newtype BIF m = BIF { runBIF :: m () }

-- | Type for RASCaL value (extends type c).
data Value c ast
  = Const   c             -- ^ Plain old constant of type "c"
  | Closed (Closure ast)  -- ^ Evaluated function, carries its scope
  | Module (Scope   ast)  -- ^ Evaluated object
  deriving (Eq, Show, Functor, Foldable, Traversable)

-- | Representation for closure
data Closure ast = Closure
  { closScope :: Scope ast  -- ^ Captured scope
  , closBody  :: ast        -- ^ Body of function
  }
  deriving (Eq, Show, Functor, Foldable, Traversable)

-- | Request to create an object
data Object ast = Object
  { oMethods ::  Scope ast  -- Methods
  , oCapture :: [Name]      -- Values to capture from stack
  }
  deriving (Eq, Show, Functor, Foldable, Traversable)

makePrisms ''Value

Scope.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Scope
  ( Scope
  , fromList
  , search
  , toList
  )
  where

import Control.Monad.Catch (MonadThrow, throwM, Exception)

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

import Name (Name)

-- | Scope, a map between var names and their values
newtype Scope a = Scope { unScope :: Map Name a }
  deriving (Eq, Show, Functor, Foldable, Traversable, Monoid)

fromList :: [(Name, a)] -> Scope a
fromList = Scope . Map.fromList

search :: Name -> Scope a -> Maybe a
search name = Map.lookup name . unScope

toList :: Scope a -> [(Name, a)]
toList = Map.toList . unScope

Stack.hs

module Stack
  ( T
  , empty
  , fromList
  , push, pushAll
  , pop, pops
  , newerThan
  , time
  ) where

import Control.Monad.Catch

import Data.Traversable (for)

data T a = Stack
  { sTime  ::   Integer
  , sElems :: [(Integer, a)]
  }
  deriving Show

time :: Stack.T a -> Integer
time = sTime

empty :: Stack.T a
empty = Stack 0 []

push :: a -> Stack.T a -> Stack.T a
push a (Stack t rest) = Stack (t + 1) ((t, a) : rest)

pushAll :: [a] -> Stack.T a -> Stack.T a
pushAll list stack = foldr push stack list

fromList :: [a] -> Stack.T a
fromList list = pushAll list empty

data StackUnderflow = StackUnderflow deriving Show

instance Exception StackUnderflow

pop :: MonadThrow m => Stack.T a -> m (a, Stack.T a)
pop (Stack t ((_, a) : rest)) = return (a, Stack t rest)
pop  _                        = throwM StackUnderflow

pops :: MonadThrow m => Integer -> Stack.T a -> m ([a], Stack.T a)
pops 0 s = return ([], s)
pops n s = do
  (a,   r)   <- pop s
  (res, end) <- pops (n - 1) r
  return (a : res, end)

newerThan :: Integer -> Stack.T a -> ([a], Stack.T a)
newerThan t stack = case stack of
  Stack tN ((t', a) : rest)
    | t' <= t   -> ([],      stack)
    | otherwise -> (a : res, stack')
      where
        (res, stack') = newerThan t (Stack tN rest)

  _ -> ([], empty)

test.rscl

1
{
  dup2: (dup | dup) (. | swap | .) ;
  count,
} =>
  count count dup2

VM.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module VM
  ( VM
  , VMState (..)
  , getScope
  , setScope
  , getBuiltins
  , withScope
  , withLocalDefs
  , push
  , pop
  , popThe
  , pops
  , searchVia
  , produced
  , StackEmpty (..)
  , TypeError  (..)
  ) where

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

import Data.Foldable
import Data.Monoid
import Data.Traversable

import Program
import Scope
import Name
import qualified Stack

data VMState c = VMState
  { _vmsScope :: Scope (Program c)              -- Current scope
  , _vmsStack :: Stack.T (Value c (Program c))  -- Current data stack
  }

makeLenses ''VMState

-- | VM interface (can read/write VM state, can throw, can read BIFs).
type VM c m =
  ( MonadCatch                  m
  , MonadReader (Scope (BIF m)) m
  , MonadState  (VMState c)     m
  )

getScope :: VM c m => m (Scope (Program c))
getScope = use vmsScope

setScope :: VM c m => Scope (Program c) -> m ()
setScope ctx = vmsScope .= ctx

getBuiltins :: VM c m => m (Scope (BIF m))
getBuiltins = ask

getStack :: VM c m => m (Stack.T (Value c (Program c)))
getStack = use vmsStack

setStack :: VM c m => Stack.T (Value c (Program c)) -> m ()
setStack ctx = vmsStack .= ctx

-- | Temporarily sets scope.
withScope :: VM c m => Scope (Program c) -> m () -> m ()
withScope ctx action = do
  old <- getScope
  setScope ctx
  action
  setScope old

-- | Temporarily adds scope.
withLocalDefs :: VM c m => Scope (Program c) -> m () -> m ()
withLocalDefs ctx action = do
  old <- getScope
  setScope (ctx <> old)
  action
  setScope old

push :: VM c m => Value c (Program c) -> m ()
push val = vmsStack %= Stack.push val

pops :: VM c m => Int -> m [Value c (Program c)]
pops count = do
  list <- for [1.. count] $ \_ -> pop
  return (reverse list)

pop :: VM c m => m (Value c (Program c))
pop = do
  stack <- getStack
  (a, rest) <- Stack.pop stack
  setStack rest
  return a

popThe :: VM c m => Prism' (Value c (Program c)) a -> m a
popThe prizm = do
  it <- pop
  case it^? prizm of
    Just yes -> return yes
    Nothing  -> throwM TypeError

-- | Run the action and pop all elements it has added to the stack.
produced :: VM c m => m () -> m [Value c (Program c)]
produced action = do
  old <- getStack
  action
  new <- getStack
  let (added, remains) = Stack.newerThan (Stack.time old) new
  setStack remains
  return added

-- | Get context from some action and then search.
searchVia :: MonadThrow m => m (Scope a) -> Name -> m a
searchVia method name = do
  ctx <- method
  case search name ctx of
    Just it -> return it
    Nothing -> throwM (NotFound name)

data NotFound   = NotFound Name deriving Show
data StackEmpty = StackEmpty    deriving Show
data TypeError  = TypeError     deriving Show

instance Exception NotFound
instance Exception TypeError
instance Exception StackEmpty