Instr.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}

module Instr where

import Prelude hiding (drop)

import Data.Map (Map)
import Data.String

data Value c where
    Constant :: c -> Value c
    Lambda   :: Instr c -> Value c
    Frame    :: Map String (Instr c) -> Value c
    Symbol   :: String -> Value c

    deriving (Eq, Show)

instance Num (Value Integer) where
    fromInteger = Constant . fromInteger

data Instr c where
    Push     :: Value c -> Instr c
    (:->)    :: [Int] -> [Int] -> Instr c
    Group    :: [[Instr c]] -> Instr c
    External :: String -> Instr c

    deriving (Eq, Show)

instance IsString (Instr c) where
    fromString = External

Machine.hs

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

module Machine where

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

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

import qualified Debug.Trace as Debug

import Instr

data Env c = Env
    { _external :: forall m. Interprets c m => Map String (m ())
    }

data Status c = Status
    { _stack  :: [(Int, Value c)]
    , _time   :: Int
    , _scoped :: [Map String (Instr c)]
    }
    deriving Show

type Interprets c m =
    ( MonadState  (Status c) m
    , MonadReader (Env    c) m
    , MonadCatch m
    , MonadIO    m
    , Show c
    )

type M c =
     StateT  (Status c)
    (ReaderT (Env c)
     IO) ()

makeLenses ''Env
makeLenses ''Status

interpret :: (forall m. Interprets c m => Map String (m ())) -> [Value c] -> M c -> IO (Status c)
interpret stdlib list action = do
    let unState = execStateT action state0
    unRead <- runReaderT unState env0
    return unRead
  where
    state0 = Status
        { _stack  = reverse (zip [0..] (reverse list))
        , _time   = length list
        , _scoped = [Map.empty]
        }

    env0 = Env
        { _external = stdlib
        }

trace :: (Interprets c m, Show s) => s -> m () -> m ()
trace s action = do
    old <- use stack
    action
    new <- use stack

    Debug.traceShowM $ show s ++ ":\n\t" ++ show old ++ " -> " ++ show new ++ "\n"

step :: Interprets c m => Instr c -> m ()
step instr = do
    case instr of
        Push (Lambda instr) -> do
            res <- compile instr
            push [Lambda instr]

        Push val -> do
            push [val]

        ins :-> outs -> do
            args <- pops (length ins)

            let mapping = Map.fromList $ zip ins args
            let res     = map (mapping Map.!) outs

            push (reverse res)

        External name -> do
            mbInstr <- uses scoped (findVar name)
            case mbInstr of
                Just it -> step it
                Nothing -> do
                    mbFunc <- views external (Map.lookup name)
                    case mbFunc of
                        Just it -> it
                        Nothing -> throwM (NotFound name)

        Group iss -> do
            pushBacks <- for iss $ \is ->
                diff $ for_ is step

            push $ reverse $ join pushBacks

findVar name [] = Nothing
findVar name (frame : rest) =
    Map.lookup name frame <|> findVar name rest

compile :: Interprets c m => Instr c -> m (Instr c)
compile instr = case instr of
    Push (Lambda prog) -> do
        cs <- compile prog
        return $ Push $ Lambda cs

    Push (Frame fields) -> do
        css <- for fields compile
        return $ Push $ Frame css

    Group css -> do
        css' <- (traverse.traverse) compile css
        return $ Group css'

    External name -> do
        mbInstr <- uses scoped (findVar name)
        case mbInstr of
            Just it -> return it
            Nothing -> return $ External name

    other -> do
        return other

optimise :: Instr c -> Instr c
optimise = go
  where
    go i = case i of
        Group css       -> Group (map (>>= ungroup) css)
        Push (Lambda i) -> Push (Lambda (go i))
        Push (Frame  f) -> Push (Frame (fmap go f))
        other           -> other

    ungroup (Group [cs]) = cs
    ungroup  other       = [other]

data End          = End             deriving (Show)
data Underflow    = Underflow       deriving (Show)
data NotAFunction = NotAFunction    deriving (Show)
data NotFound     = NotFound String deriving (Show)
data UnmatchedRBR = UnmatchedRBR    deriving (Show)
data ExpectedName = ExpectedName    deriving (Show)

instance Exception End
instance Exception Underflow
instance Exception NotAFunction
instance Exception NotFound
instance Exception UnmatchedRBR
instance Exception ExpectedName

diff :: Interprets c m => m () -> m [Value c]
diff action = do
    old <- use stack
    action
    new <- use stack
    pops (delta old new)

delta :: [(Int, a)] -> [(Int, a)] -> Int
delta []              = length
delta ((v, _) : rest) = length . filter ((v <) . fst)

pop :: Interprets c m => m (Value c)
pop = do
    list <- use stack
    case list of
        [] -> do
            throwM End
        (_, a) : rest -> do
            stack .= rest
            return a

pops :: Interprets c m => Int -> m [Value c]
pops count = do
    list <- use stack
    let (res, rest) = splitAt count list

    when (length res < count) $ do
        throwM Underflow

    stack .= rest
    return (map snd res)

push :: Interprets c m => [Value c] -> m ()
push az = do
    for_ az $ \a -> do
        t <- use time
        time  %= (+ 1)
        stack %= ((t, a) :)

Parser.hs

module Parser (program, parseFromFile) where

import Control.Applicative

import Text.ParserCombinators.Parsec hiding (token, (<|>), many)
import Text.ParserCombinators.Parsec.Number

import           Text.Parsec.Language
import           Text.Parsec.Token

import Instr
import Value

-- data Value c where
--     Constant :: c -> Value c
--     Lambda   :: Instr c -> Value c
--     Frame    :: Map String (Instr c) -> Value c

-- data Instr c where
--     Push     :: Value c -> Instr c
--     (:->)    :: [Int] -> [Int] -> Instr c
--     Group    :: [[Instr c]] -> Instr c
--     External :: String -> Instr c

-- data Val
--     = Double Double
--     | String String
--     | Integer Integer

program :: Parser (Instr Val)
program = spaces >> Group <$> groupBody

value = constant <|> lambda

constant = Constant <$> val

val = double <|> theString <|> theInteger

double = Double <$> t fractional
theString = String <$> t strParser
theInteger = Integer <$> t int

lambda = t $ do
    token "["
    i <- do
        gb <- groupBody
        case gb of
            [[i]] -> return i
            gb   -> return (Group gb)
    token "]"
    return (Lambda i)

instr = push <|> comb <|> group <|> sym <|> ext

sym = t (do
    char ':'
    n <- name
    return $ Push $ Lambda $ External n)
  <|> t (do
    n <- some (noneOf " \n\t()[]|?:")
    token ":"
    return $ Push $ Lambda $ External n)

push = Push <$> value

comb = t $ do
    char '?'
    ins <- some (read . pure <$> digit)
    try $ string "->"
    outs <- many (read . pure <$> digit)
    return (ins :-> outs)

group = t $ do
    token "("
    gb <- groupBody
    token ")"
    return (Group gb)

groupBody = do
    some instr `sepBy1` t (char '|')

ext = External <$> name

name = t (some (noneOf " \n\t()[]|?:"))

token = t . string

t p = try p <* spaces

strParser = stringLiteral $ makeTokenParser haskellDef

Stdlib.hs

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

module Stdlib where

import Prelude hiding (drop)

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

import qualified Data.Map as Map

import Value
import Instr
import Machine
import PP

stdlib :: Interprets Val m => Map.Map String (m ())
stdlib = Map.fromList
    [ ("!", applyImpl)
    , ("{", openImpl)
    , ("}", closeImpl)
    , (";", bangImpl)
    , ("+", monotype (+) (+) (++))
    , ("-", monotype subtract subtract (error "cannot - strings"))
    , ("*", monotype (*) (*) (error "cannot * strings"))
    , ("**", monotype (**) (^) (error "cannot ** strings"))
    , ("/", monotype (/) div (error "cannot / strings"))
    , ("%", monotype (error "cannot % doubles") mod (error "cannot % strings"))
    , ("save", saveImpl)
    , ("open", openOImpl)
    ]

apply = External "apply"
open  = External "{"
close = External "}"
bang  = External ";"

i     = [1]    :-> [1]
dup   = [1]    :-> [1, 1]
swap  = [1, 2] :-> [2, 1]
drop  = [1]    :-> []

dip   = Group [[swap, Group [[i], [apply]]]]

openImpl :: Interprets c m => m ()
openImpl = do
    scoped %= (Map.empty :)

closeImpl :: Interprets c m => m ()
closeImpl = do
    scopes <- use scoped
    case scopes of
        [] -> throwM UnmatchedRBR
        (a : rest) -> do
            push [Frame a]
            scoped .= rest

bangImpl :: Interprets c m => m ()
bangImpl = do
    [body, name] <- pops 2
    case (name, body) of
        (Lambda (External n), Lambda b) -> do
            scoped._head.at(n) .= Just b

        (Lambda (External n), _) ->
            scoped._head.at(n) .= Just (Push body)

        _ ->
            throwM ExpectedName

applyImpl :: Interprets c m => m ()
applyImpl = do
    item <- pop
    case item of
        Lambda it -> step it
        _         -> throwM NotAFunction

monotype
    :: Interprets Val m
    => (Double  -> Double  -> Double)
    -> (Integer -> Integer -> Integer)
    -> (String  -> String  -> String)
    -> m ()
monotype ds is ss = do
    [Constant a, Constant b] <- pops 2
    push [Constant $ onConstants a b]
  where
    onConstants (Double  d) (Double  c) = Double  $ d `ds` c
    onConstants (Integer d) (Integer c) = Integer $ d `is` c
    onConstants (String  d) (String  c) = String  $ d `ss` c

data ExpectedString = ExpectedString deriving Show
data ExpectedObject = ExpectedObject deriving Show

instance Exception ExpectedString
instance Exception ExpectedObject

saveImpl :: (Interprets Val m) => m ()
saveImpl = do
    fname <- pop
    case fname of
        Constant (String it) -> do
            scope <- use scoped
            liftIO $ writeFile it (show . (<+> text "open") . fsep . reverse . map pretty $ scope)

        other -> do
            throwM ExpectedString

openOImpl :: (Interprets Val m) => m ()
openOImpl = do
    o <- pop
    case o of
        Frame obj -> do
            scoped %= (obj :)

        other -> do
            throwM ExpectedObject

test.joy

:drop [ ?1-> ] ;

:math {
    :add [-] ;
    :inc [1 add] ;
    :val [2 3 drop inc] ;
    val ?12->21
} ;

"aha.joy" save

Value.hs

module Value where

data Val
    = Double Double
    | String String
    | Integer Integer
    deriving (Eq, Show)