Shiba

fact.out

Right [TInt 3628800]

fact.shiba

fact: {
  @ if = :x 0 { 1 } { * :x fact - 1 :x }
  x:
}

fact 10

Main.hs

module Main where

import Text.Peggy
import Shiba

main =
  getContents >>= \code ->
  (return $ parseString Shiba.expr "<stdin>" code >>= \ws -> return (Shiba.evalF' ws Shiba.empty [])) >>= print

mutual.shiba

true: { = 0 0 }
false: { = 0 1 }
even: { @ if = 0 :x { true  } { odd  - 1 :x } x: }
odd:  { @ if = 0 :x { false } { even - 1 :x } x: }

even 42
even 99

Shiba.hs

{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}

module Shiba where

import Data.Maybe
import Text.Peggy

type ShibaId = String

type ShibaEnv = [(ShibaId, ShibaT)]

insert :: a -> b -> [(a, b)] -> [(a, b)]
insert k v e = (k, v) : e

empty :: [(a, b)]
empty = []

merge :: [(a, b)] -> [(a, b)] -> [(a, b)]
merge = (++)

type ShibaStack = [ShibaT]

data ShibaT = TBool Bool
            | TInt Integer
            | TWord ShibaW
            | TList [ShibaT]
            | TFun [ShibaW]
            deriving (Show)

data ShibaW = WQuote [ShibaW]
            | WInt Integer
            | WDrop
            | WAdd
            | WSub
            | WMul
            | WDiv
            | WEq
            | WIf
            | WNil
            | WCons
            | WIsNil
            | WSnoc
            | WSet ShibaId
            | WGet ShibaId
            | WFun ShibaId
            | WApply
            deriving (Show)

[peggy|

wint ::: ShibaW
  = [0-9]+ { WInt (read $1) }

identifier :: String
  = [_a-zA-Z][_0-9a-zA-Z]* { $1 : $2 }

wset ::: ShibaW
  = identifier ':' { WSet $1 }

wget ::: ShibaW
  = ':' identifier { WGet $1 }

wfun ::: ShibaW
  = identifier { WFun $1 }

wapply ::: ShibaW
  = '@' { WApply }

wdrop ::: ShibaW
  = 'drop' { WApply }

wadd ::: ShibaW
  = '+' { WAdd }

wsub ::: ShibaW
  = '-' { WSub }

wmul ::: ShibaW
  = '*' { WMul }

wdiv ::: ShibaW
  = '/' { WDiv }

weq ::: ShibaW
  = '=' { WEq }

wnil ::: ShibaW
  = 'nil' { WNil }

wcons ::: ShibaW
  = 'cons' { WCons }

wisnil ::: ShibaW
  = 'nil?' { WIsNil }

wsnoc ::: ShibaW
  = 'snoc' { WSnoc }

wif ::: ShibaW
  = 'if' { WIf }

wquote ::: ShibaW
  = "{" expr "}" { WQuote $1 }

term :: ShibaW
  = wapply / wdrop
  / wadd / wmul / wsub / wdiv
  / wnil / wcons / wsnoc / wisnil / weq / wif
  / wquote / wint / wget / wset / wfun

expr :: [ShibaW]
  = term* { $1 }

|]

evalW :: ShibaW -> ShibaStack -> ShibaStack
evalW (WQuote ws) s = TFun ws : s
evalW (WInt i) s = TInt i : s
evalW WDrop (_ : s) = s
evalW WAdd (TInt x : TInt y : s) = TInt (y + x) : s
evalW WSub (TInt x : TInt y : s) = TInt (y - x) : s
evalW WMul (TInt x : TInt y : s) = TInt (y * x) : s
evalW WDiv (TInt x : TInt y : s) = TInt (y `div` x) : s
evalW WEq (TInt x : TInt y : s) = TBool (y == x) : s
evalW WNil s = TList [] : s
evalW WCons (x : TList l : s) = TList (x : l) : s
evalW WIsNil (TList l : s) = TBool (null l) : s
evalW WSnoc (TList (x : l) : s) = x : TList l : s
evalW WIf (TBool True : x : _ : s) = x : s
evalW WIf (TBool False : _ : y : s) = y : s

evalF :: [ShibaW] -> (ShibaEnv, ShibaStack) -> (ShibaEnv, ShibaStack)
evalF [] (e, s)  = (e, s)
evalF (WSet k : ws) (e, s) = let (e1, (x : s1)) = evalF ws (e, s)
                             in (insert k x e1, s1)
evalF (WGet k : ws) (e, s) = let (e1, s1) = evalF ws (e, s)
                             in (e1, fromJust (lookup k e1) : s1)
evalF (WFun k : ws) (e, s) = let (e1, s1) = evalF ws (e, s)
                                 (Just (TFun ws1)) = (lookup k e1)
                                 s2 = evalF' ws1 e1 s1
                             in (e1, s2)
evalF (WApply : ws) (e, s) = let (e1, TFun ws1 : s1) = evalF ws (e, s)
                                 s2 = evalF' ws1 e1 s1
                             in (e1, s2)
evalF (w : ws) (e, s) = let (e1, s1) = evalF ws (e, s)
                        in (e1, evalW w s1)

evalF' :: [ShibaW] -> ShibaEnv -> ShibaStack -> ShibaStack
evalF' ws e s = let (e1, s1) = evalF ws (merge e e1, s) in s1