CS计算机代考程序代写 compiler {-# LANGUAGE NoMonomorphismRestriction #-}

{-# 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