{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
— A stack machine as an instance of restricted Symantics
— (restricted to arithmetics at present)
module StackBasedLangUnfilled where
import Prelude hiding ((>>), drop)
import qualified Prelude
——————————————————————————-
— These 2 imports are purely “for show”, we will not really use them!
import Debug.Trace ( traceShow )
import GHC.IO (unsafePerformIO)
——————————————————————————-
{——————————————————————————
— A Forth-like stack-based language
——————————————————————————}
class StackMachine stk where
empty :: stk ()
push :: Show a => a -> stk s -> stk (a, s)
drop :: Show a => stk (a, s) -> stk s
swap :: stk (a, (b, s)) -> stk (b, (a, s))
dup :: stk (a, s) -> stk (a, (a, s))
sadd :: Num a => stk (a, (a, s)) -> stk (a, s)
smul :: Num a => stk (a, (a, s)) -> stk (a, s)
sleq :: Ord a => stk (a, (a, s)) -> stk (Bool, s)
newtype R a = R { unR :: a }
— An interepreter
instance StackMachine R where
empty = undefined — TODO
push x (R s) = undefined — TODO
drop (R (x, s)) = undefined — TODO
swap (R (x, (y, s))) = undefined — TODO
dup (R (x, s)) = undefined — TODO
sadd (R (x, (y, s))) = undefined — TODO
smul (R (x, (y, s))) = undefined — TODO
sleq (R (x, (y, s))) = undefined — TODO
runR :: (R () -> R a) -> a
runR prog = unR $ prog empty
{——————————————————————————
— A few examples…
——————————————————————————}
test1 = drop $ sadd $ push 1 $ push 2 empty
test2 = drop $ drop $ dup $ push 1 empty
test3 = sadd $ push 2 $ push 3 empty
{——————————————————————————
— Let’s make it a bit prettier!
——————————————————————————}
— (>>) = flip (.)
(>>) = flip ($)
betterTest1 = empty
>> push 2
>> push 1
>> sadd
>> push 3
>> sleq
{——————————————————————————
— A basic “compiler”/printer
——————————————————————————}
— `Compiler’
newtype C a = C { unC :: String }
liftC :: (String -> String) -> C a -> C b
liftC f (C x) = C $ f x
instance StackMachine C where
empty = undefined — TODO
push x = undefined — TODO
swap = undefined — TODO
drop = undefined — TODO
dup = undefined — TODO
sadd = undefined — TODO
smul = undefined — TODO
sleq = undefined — TODO
{——————————————————————————
— Recalling our standard language…
——————————————————————————}
class Symantics repr where
int :: Int -> repr Int — int literal
bool :: Bool -> repr Bool — bool literal
add :: repr Int -> repr Int -> repr Int
mul :: repr Int -> repr Int -> repr Int
leq :: repr Int -> repr Int -> repr Bool
{——————————————————————————
— Converting our language into our stack machine language!
——————————————————————————}
newtype RR c a = RR { unRR :: forall s. c s -> c (a,s) }
instance StackMachine c => Symantics (RR c) where
int x = undefined — TODO
bool x = undefined — TODO
add x y = undefined — TODO
leq x y = undefined — TODO
mul x y = undefined — TODO
runRRR m = unR $ unRR m empty
runRRC m = unC $ unRR m empty
test4 = (int 1 `add` int 2) `add` (int 3 `add` int 4)
— >>> runRRR test4
— >>> runRRC test4
test5 = (int 1 `add` int 2) `mul` (int 3 `add` int 4) `leq` int 9
— >>> runRRR test5
— >>> runRRC test5