Agony.hs

{-# language GeneralizedNewtypeDeriving #-}
{-# language DeriveFunctor #-}
{-# language LambdaCase #-}
{-# language FlexibleInstances #-}

import Control.Applicative (Alternative (..), optional)
import Control.Category ((>>>))
import Control.Monad (ap, void, guard)

import Data.Maybe (fromMaybe)
import Data.List (intercalate)

import Debug.Trace as Debug

import qualified Text.PrettyPrint as PP

data Fix f = In { out :: f (Fix f) }

cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . out

refold :: Functor f => (f (Fix f) -> f (Fix f)) -> Fix f -> Fix f
refold = cata . (In .)

type Agony = Fix Agony_

data Agony_ self
    = Call Name
    | String String
    | Number Double
    | Quote  self
    | Seq    [self]
    | Par    [self]
    | Obj    [(Name, self)]
    | Open   self self
    deriving (Functor)
    
class Pretty p where
    pp :: p -> PP.Doc

instance Pretty (Fix Agony_) where
    pp = clean >>> cata (\case
        Call name -> PP.text name
        String s  -> PP.doubleQuotes (PP.text s)
        Number d  -> PP.double d
        Quote  q  -> PP.brackets q
        Seq    s  -> PP.fsep s
        Par    p  -> PP.parens (PP.fsep $ PP.punctuate (PP.text " |") p)
        Obj   ns  -> PP.braces (PP.vcat $ map field ns)
        Open x y  -> PP.hang (PP.text "open") 4 x PP.$$ PP.hang (PP.text "in") 4 y)
      where
        field (n, b) = PP.hang (PP.text n PP.<> PP.text ":") 4 b

clean = refold $ \case
    Seq list -> Seq (map In . cleanSeq . map out $ list)
    other    -> other
  where
    cleanSeq (String _ : Call "_" : rest) = cleanSeq rest
    cleanSeq (x : rest) = x : cleanSeq rest
    cleanSeq []         = []

instance Show (Fix Agony_) where
    show = show . pp

type Name = String

newtype Parser a = Parser { runParser :: Stream -> (Either String a, Stream) }
    deriving (Functor)
    
data Stream = Stream
    { position :: Position
    , stream   :: String
    }
    deriving (Eq)

instance Show Stream where
    show = show . position
    
instance Show Position where
    show (Position line col _) = "line " ++ show line ++ ", column " ++ show col

parse :: Parser a -> String -> (Either String a, Stream)
parse (Parser p) s = p (Stream (Position 1 1 0) s)

parseFromFile :: Parser a -> String -> IO a
parseFromFile p name = do
    text <- readFile name
    case p `parse` text of
        (Right a, _) -> return a
        (Left e, rest) -> do
            error $ e ++ " at " ++ show rest

advance :: Stream -> (Maybe Char, Stream)
advance itself@ (Stream pos s) = case s of
    []          -> (Nothing, itself)
    '\n' : rest -> (Just '\n', Stream (nextLine   pos) rest)
    c    : rest -> (Just   c , Stream (nextColumn pos) rest)
  where
    nextLine   (Position line column offset) = Position (line + 1)           1  (offset + 1)
    nextColumn (Position line column offset) = Position  line      (column + 1) (offset + 1)

data Position = Position
    { line   :: Int
    , column :: Int
    , offset :: Int
    }
    deriving (Eq)
    
instance Applicative Parser where
    pure  = return
    (<*>) = ap
    
instance Monad Parser where
    return = Parser . (,) . Right
    
    Parser runL >>= callb = Parser $ \s ->
        case runL s of
            (Right a, s') -> callb a `runParser` s'
            (Left  e, s') -> (Left e, s')

instance Alternative Parser where
    empty = Parser . (,) $ Left "no choices left"
    
    Parser l <|> Parser r = Parser $ \s ->
        case l s of
            (Right a, s')             -> (Right a, s')
            (Left  a, s') | s == s'   -> r s
                          | otherwise -> (Left  a, s')
                          
try :: Parser a -> Parser a
try (Parser p) = Parser $ \s ->
    case p s of
        (Left e, _) -> (Left e, s)
        other       -> other
        
char :: Char -> Parser Char
char c = satisfy (== c) <?> ("char `" ++ [c] ++ "`")

satisfy :: (Char -> Bool) -> Parser Char
satisfy pred = Parser $ \s ->
    case advance s of
        (Nothing, s')            -> (Left "not the end of file", s')
        (Just c, s') | pred c    -> (Right c, s')
                     | otherwise -> (Left [c], s)
                     
string :: String -> Parser String
string s = mapM char s

token :: String -> Parser ()
token s = do
    _ <- try (string s)
    spaces
  <?> s

infix 1 <?>
Parser p <?> msg = Parser $ \s ->
    case p s of
        (Left _, s') -> (Left msg, s')
        other        -> other

spaces :: Parser ()
spaces = void $ many space
  where
    space = satisfy (`elem` " \n\t\r")

noneOf :: String -> Parser Char
noneOf set = satisfy (`notElem` set)

oneOf :: String -> Parser Char
oneOf set = satisfy (`elem` set)

name :: Parser String
name = nameRaw <* spaces

nameRaw :: Parser String
nameRaw = try (do
    n   <-        noneOf "[](){}:;|0123456789 \t\n\r"
    ame <- many $ noneOf "[](){}:;| \t\n\r"
    
    guard ((n:ame) `notElem` reservedWords)
    return (n:ame))
  <?> "name"

call :: Parser Agony
call = In . Call <$> name

number :: Parser Agony
number = do
    r <- int
    i <- optional $ do
        string "."
        int
    spaces
    return $ In $ Number $ read $ r ++ "." ++ fromMaybe "0" i
  where
    int = some (oneOf "1234567890")

stringLiteral :: Parser Agony
stringLiteral = do
    blocks <- some block
    spaces
    return $ In $ String $ intercalate ['"'] blocks
  where
    block = do
        char '"'
        chars <- many (noneOf ['"'])
        char '"'
        return chars

quote :: Parser Agony
quote = do
    token "["
    p <- program
    token "]"
    return $ In $ Quote p

seqAgony :: Parser Agony
seqAgony = do
    token "("
    p <- program
    token ")"
    return $ p

wrapIfMultiple f [p] = p
wrapIfMultiple f  p  = f p

program :: Parser Agony
program = wrapIfMultiple (In . Par) <$> ((wrapIfMultiple (In . Seq) <$> some term) `sepBy` token "|")

sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy p sep = do
    x  <- p
    xs <- many (sep *> p)
    return (x : xs)
  <|> 
    return []
    
object :: Parser Agony
object = do
    token "{"
    fs <- many (token ";" >> field)
    token "}"
    return $ In $ Obj fs
  where
    field = do
        _ <- optional stringLiteral
        n <- symbolRaw
        b <- program
        return (n, b)
    
symbol :: Parser Agony
symbol = In . Quote . In . Call <$> symbolRaw
    
symbolRaw :: Parser String
symbolRaw = do
    char ':'
    name
  <|> try (nameRaw <* char ':' <* spaces)
    
opening :: Parser Agony
opening = do
    token "open"
    o <- program
    token "in"
    ctx <- program
    return $ In $ Open o ctx
    
term :: Parser Agony
term = seqAgony <|> quote <|> stringLiteral <|> number <|> symbol <|> call <|> object <|> opening

toplevel = spaces >> program

reservedWords = words "open in"

agony.py

'''
    Create class of given superclass, name, constructor args and methods.

    Generates constructor, nice toString() and structural equality via "==".

    All methods are pattern-matching:

        class List:
            pass

        Push = adt(List, "Push", "x", "xs",

            #            *--+-- instead of 'self'
            #            v  v
            map = lambda x, xs, f: Push(f(x), xs.map(f))
        )

        Empty = adt(List, "Empty",
            map = lambda f: Empty()
        )
'''
def adt(root, name, *fields, **methods):

    '''
        Constructor
    '''
    def assign(self, *values):
        for (field, value) in zip(fields, values):
            setattr(self, field, value)

    def show_field(self):
        return lambda field: (
            field + " = " + str(getattr(self, field))
        )

    '''
        ToString
    '''
    def show(self):
        return (
            name
            + " { "
            + ", ".join(map(show_field(self), fields))
            + " }"
        )

    '''
        Structural equality
    '''
    def equals(self, other):
        if type(self) != type(other):
            return False

        for field in fields:
            if getattr(self, field) != getattr(other, field):
                return False

        return True

    '''
        Take a method that receives fields as leading args,
        return a method that receives 'self' as single leading arg instead.
    '''
    def pattern_match(body):
        def real_method(self, *args, **kwargs):
            preargs = []

            for field in fields:
                preargs.append(getattr(self, field))

            return body(*preargs, *args, **kwargs)

        return real_method

    return type(
        name,
        (root,),  # its a tuple of one element
        dict({ method : pattern_match(methods[method]) for method in methods },
            __init__ = assign,
            __str__  = show,
            __repr__ = show,
            __eq__   = equals
        )
    )

'''
    Method invocation is first-class entity now.

    append4 = call("append", 4)

    list1 = append4([1,2,3])
'''
def call(name, *args, **kwargs):
    return lambda x: getattr(x, name)(*args, **kwargs)

'''
    Python is officially good language now.

    Okay, enough with machinery, below is our business logic.
'''

'''
    Root class for Abstract Syntax Tree.
'''
class Ast:
    '''
        Compile to JS.
    '''
    def js(self):
        raise NotImplementedError(f"{type(self).__name__}.js")

    '''
        Pretty-print.
    '''
    def pp(self):
        raise NotImplementedError(f"{type(self).__name__}.pp")

'''
    We can't have { and } inside {}-interpolator,
    and {"{"} is slower to type than {L}, so...
'''
L = "{"
R = "}"

def indent(lines):
    return list(map(lambda line: "  " + line, lines))

'''
    Call a function.
'''
Call = adt(Ast, "Call", "name",
    js = lambda name: [name + '()'],
    pp = lambda name:    name
)

'''
    Wrap an item into a function.
    Item will be evaluated when function is invoked.
'''
Quote = adt(Ast, "Quote", "item",
    js = lambda item: ['__push(() => {'] + indent(item.js()) + ['})'],
    pp = lambda item: f'[{item.pp()}]'
)

'''
    Its "with (object) { context }", essentially.
'''
Let = adt(Ast, "Let", "object", "context",
    js = lambda object, context: object.js() + ['with (__pop()) {'] + indent(context.js()) + ['}'],
    pp = lambda object, context: f'let {object.pp()} in {context.pp()} end'
)

'''
    Non-inlined compilation-to-js for object.
'''
def js_object(mapping):
    keyset   = set(mapping.keys())
    bodies   = []
    exported = []

    for func, body in mapping.items():
        bodies += ['function ' + func + '() {'] + indent(body.js()) + ['}']
        exported.append(func + ",")

    #        v-- we are hiding object methods in IIFE here
    return (
        ['(function () {']
            + indent(bodies
                + ['__push({']
                    + indent(exported)
                + ['})'])
        + ['})()', '']
    )

'''
    Non-inlined pretty-printing for object.
'''
def pp_object(mapping):
    keyset   = set(mapping.keys())
    bodies   = []
    exported = []

    for func, body in mapping.items():
        bodies.append(f'{func}: {body.pp()}')
        exported.append(func)

    return f'{L} {"; ".join(bodies)} {R}'

'''
    Create an object.
'''
Object = adt(Ast, "Object", "map",
    js = js_object,
    pp = pp_object
)

from functools import reduce

'''
    Evaluate items in a sequence.
'''
Seq = adt(Ast, "Seq", "items",
    js = lambda items: reduce(lambda x, y: x + y, map(call("js"), items), []),
    pp = lambda items: " ".join(map(call("pp"), items)),
)

'''
    Evaluate items in parallel
'''

Par = adt(Ast, "Par", "paths",
    js = lambda paths: Seq([Quote(Seq([*map(Quote, paths)])), Call("__par")]).js(),
    pp = lambda paths: "(" + " | ".join(map(call("pp"), paths)) + ")"
)

'''
    Evaluate number literal.
'''
Number = adt(Ast, "Number", "number",
    js = lambda number: [f'__push({number})'],
    pp = lambda number:           str(number)
)

'''
    Evaluate string literal.
'''
String = adt(Ast, "String", "string",
    js = lambda string: [f'__push("{string}")'],
    pp = lambda string:            f'"{string}"'
)

def compile_to_js(expr):
    return "\n".join(['let {__push, __pop, __par} = require("./runtime.js")', ''] + expr.js())

expr = Let(
    Object({
        'bar': Seq([
            Quote(String("foo")),
            Number(2)
        ]),
        'bur': Seq([
            String("foo"),
            Quote(Number(2))
        ]),
    }),

    Par([
        Seq([Call("bar"), Call("foo")]),
        Seq([Call("foo"), Call("bar")])
    ]),
    Call("bar")
)

print("Expression:    ", expr)
print()
print("Compiled:      ")
print(compile_to_js(expr))
print()
print("Pretty-printed:", expr.pp())
print()
print("Equality test: ", Quote(String("foo")) == Quote(String("foo")))
print("Equality test: ", Quote(String("foo")) == Quote(String("bar")))

def parse(text):

    i = 0
    stack = []

    def push(x):
        nonlocal stack
        stack += [x]
        return True
        
    def pop():
        return stack.pop() if len(stack) > 0 else None
        
    def apply(f):
        push(f(pop()))
        return True
        
    def merge(f):
        push(f(pop(), pop()))
        return True
        
    def add(x, y):
        print("add", type(x), type(y))
        return y + x
        
    def flip(f):
        return lambda x, y: f(y, x)

    def drop(_, y):
        return y
        
    def eof(k = 0):
        return i + k >= len(text)
        
    def char(k = 0):
        return "\x00" if eof() else text[i + k]
        
    def next(k = 0):
        nonlocal i
        i += (1 + k)
        
    def many(p):
        while p():
            pass
        return True
        
    def some(p):
        return p() and many(p)
            
    def oneOf(charset):
        if not eof() and charset.find(char()) >= 0:
            last = pop()
            last += char()
            push(last)
            next()
            return True

    def noneOf(charset):
        if not eof() and charset.find(char()) < 0:
            last = pop()
            last += char()
            push(last)
            next()
            return True

    def string(tok):
        j = 0
        if tok[j] != char(j):
            return False

        while (not eof(j) and j < len(tok)):
            print(tok[j], char(j))
            if tok[j] != char(j):
                return False
            j += 1

        next(len(tok) - 1)
        return True
        
    def nothing():
        return True

    def fail():
        return False

    def token(tok):
        string(tok)
        spaces()
        return True

    def spaces():
        return push("") and many(lambda: oneOf(" \n\t\r")) and merge(drop)

    def nameStart():
        return noneOf(' \t\r\n0987654321[]()|;:."')

    def nameChar():
        return noneOf(' \t\r\n[]()|;:."')

    def nameToken():
        return push("") and nameStart() and many(nameChar)

    def name():
        return nameToken() and apply(Call)

    def int():
        return push("") and many(lambda: oneOf("1234567890"))

    def call():
        return name() and spaces() and apply(Call)
            
    def number():
        return ( 
               int()
           and string('.')
           and push('.')
           and int()
           and merge(add)
           and merge(add)
           and apply (Number)
           and spaces()
        )
    
    def followedBy(p):
        nonlocal i
        k = i
        res = p()
        i = k
        return res
    
    def stringLit():
        def block():
            return (
                    string('"')
                and push('')
                and many(lambda: noneOf('"'))
                and string('"')
                and (apply(lambda s: s + '"') if followedBy(lambda: string('"')) else nothing())
            )
            
        return push("") and some(lambda: block() and merge(add)) and spaces() and apply(String)

    def rollback(p):
        nonlocal i
        k = i
        print(">", i)
        if p() or merge(drop) and fail():
            print("???", i)
            return True
        print("<", i)
        i = k
        return False

    def symbol():
        return (
            rollback(lambda: nameToken() and string(':') and push(':') and merge(flip(add)))

            or string(':') and push(':') and nameToken() and merge(add)
        )

    def expr():
        return push([]) and many(lambda: (name() or number() or stringLit()) and apply(lambda x: [x]) and merge(add) and spaces())
    
    res = expr()
    
    stack.append(text[i:])
    stack.append(res)
    return stack

print (parse ('hey123324 "hello, world!""this is a doublequote!"  "hey"'))

runtime.js

let last = arr => arr[arr.length - 1]

let stack = []
let i     = 0

let diff = version => {
    let acc = []
    while (stack.length && last(stack).version >= version) {
        acc.push(stack.pop().value)
    }
    return acc
}

let currentVersion = () => last(stack).version || 0

module.exports = {

    __push(x) {
        stack.push({version: ++i, value: x})
    },

    __pop() {
        if (!stack.length)
            throw Error("stack underflow")

        return stack.pop().value
    },

    __par() {
        let bottom = currentVersion()

        __pop()();

        let items  = diff(bottom)
        let acc    = []

        items.forEach(item => {
            let before = currentVersion()

            item()

            let delta = diff(before)

            delta.reverse()
            acc.push(delta)
        })
        acc.reverse()
        acc.forEach(layer => layer.forEach(__push))
    },

}

stdlib.js

let {__push, __pop, __par} = require("./runtime.js")

module.exports = {

    dup() {
        let x = __pop()
        __push(x)
        __push(x)
    },

    swap() {
        let x = __pop()
        let y = __pop()
        __push(x)
        __push(y)
    },

    id() {
        let x = __pop()
        __push(x)
    },

    rot() {
        let x = __pop()
        let y = __pop()
        let x = __pop()
        __push(y)
        __push(x)
        __push(z)
    },

    rec() {
        let body = __pop()

        do {
            body()
        } while (__pop())
    }

    add() {
        let x = __pop()
        let y = __pop()
        __push(x + y)
    },

    ifte() {
        let no   = __pop()
        let yes  = __pop()
        let bool = __pop()

        if (bool) {
            yes()
        } else {
            no()
        }
    }
}

test.agony

"this comment should be removed" _

open {
    ; cond:                              "[[?] [a] ...]" _
        <<                               "  ?  [[a] ...]" _
        (!  | <<)                        "  ?  [a] [...]" _
        (.. | :cond)                     "  ?  [a] :cond [...]"_
        ?
    ; =?: -< =
    ; -1: 1 <-> -
    ; -2: 2 <-> -
} in {
    ; fib:
        [ [=? 0] [0]
          [=? 1] [1]
          [True] [-< (-1 fib | -2 fib) +]
        ] cond
            
    ; diag3:
        open {
            ; sqr: -< *
        } in
            (sqr | sqr | sqr)
                 +     +
                  sqrt
                       
    ; n..m:
        open {
            ; collect:         "n m acc"_
                (-<  |  -<)    "n n m m acc"_
                (. | > | .)    "n n>m m acc"_
                <->            "n>m n m acc"_
                    [_ _]
                    [                "n m acc"_
                        -<          "n n m acc"_
                        rot          "n m n acc"_
                        (.. | push)  "n m [acc n]"_
                        collect
                    ]
                ?
        } in
            [] rot collect
            
    ;   for: ()
            
}