real tests!
This commit is contained in:
crumbtoo
@@ -4,7 +4,10 @@ Description : Core examples (may eventually be unit tests)
|
||||
-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Core.Examples where
|
||||
module Core.Examples
|
||||
( fac3
|
||||
, sumList
|
||||
) where
|
||||
----------------------------------------------------------------------------------
|
||||
import Core.Syntax
|
||||
import Core.TH
|
||||
@@ -12,6 +15,7 @@ import Core.TH
|
||||
|
||||
-- TODO: my shitty lexer isn't inserting semicolons
|
||||
|
||||
letrecExample :: Program'
|
||||
letrecExample = [coreProg|
|
||||
pair x y f = f x y;
|
||||
|
||||
@@ -27,18 +31,22 @@ letrecExample = [coreProg|
|
||||
main = f 3 4;
|
||||
|]
|
||||
|
||||
idExample :: Program'
|
||||
idExample = [coreProg|
|
||||
main = id 3;
|
||||
|]
|
||||
|
||||
indExample1 :: Program'
|
||||
indExample1 = [coreProg|
|
||||
main = twice twice id 3;
|
||||
|]
|
||||
|
||||
indExample2 :: Program'
|
||||
indExample2 = [coreProg|
|
||||
main = twice twice twice id 3;
|
||||
|]
|
||||
|
||||
indExample3 :: Program'
|
||||
indExample3 = [coreProg|
|
||||
main = letrec
|
||||
{ x = 2
|
||||
@@ -49,51 +57,63 @@ indExample3 = [coreProg|
|
||||
g a b = a;
|
||||
|]
|
||||
|
||||
negExample1 :: Program'
|
||||
negExample1 = [coreProg|
|
||||
main = negate# (id 3);
|
||||
|]
|
||||
|
||||
negExample2 :: Program'
|
||||
negExample2 = [coreProg|
|
||||
main = negate# 3;
|
||||
|]
|
||||
|
||||
negExample3 :: Program'
|
||||
negExample3 = [coreProg|
|
||||
main = twice negate# 3;
|
||||
|]
|
||||
|
||||
arithExample1 :: Program'
|
||||
arithExample1 = [coreProg|
|
||||
main = (+#) 3 (negate# 2);
|
||||
|]
|
||||
|
||||
arithExample2 :: Program'
|
||||
arithExample2 = [coreProg|
|
||||
main = negate# ((+#) 2 ((*#) 5 3));
|
||||
|]
|
||||
|
||||
ifExample1 :: Program'
|
||||
ifExample1 = [coreProg|
|
||||
main = if# True 2 3;
|
||||
|]
|
||||
|
||||
ifExample2 :: Program'
|
||||
ifExample2 = [coreProg|
|
||||
main = if# (id True) 2 3;
|
||||
|]
|
||||
|
||||
facExample :: Program'
|
||||
facExample = [coreProg|
|
||||
fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1)));
|
||||
main = fac 3;
|
||||
|]
|
||||
|
||||
pairExample1 :: Program'
|
||||
pairExample1 = [coreProg|
|
||||
main = fst (snd (fst (MkPair (MkPair 1 (MkPair 2 3)) 4)));
|
||||
|]
|
||||
|
||||
pairExample2 :: Program'
|
||||
pairExample2 = [coreProg|
|
||||
main = (if# False fst snd) (MkPair 2 3);
|
||||
|]
|
||||
|
||||
listExample1 :: Program'
|
||||
listExample1 = [coreProg|
|
||||
main = caseList# (Cons 2 Nil) 3 k;
|
||||
|]
|
||||
|
||||
listExample2 :: Program'
|
||||
listExample2 = [coreProg|
|
||||
cc f x xs = Cons (f x) (map f xs);
|
||||
map f l = caseList# l Nil (cc f);
|
||||
@@ -101,6 +121,7 @@ listExample2 = [coreProg|
|
||||
main = map negate# list;
|
||||
|]
|
||||
|
||||
listExample3 :: Program'
|
||||
listExample3 = [coreProg|
|
||||
cc f z x xs = f x (foldr f z xs);
|
||||
foldr f z l = caseList# l z (cc f z);
|
||||
@@ -108,6 +129,7 @@ listExample3 = [coreProg|
|
||||
main = foldr (+#) 0 list;
|
||||
|]
|
||||
|
||||
simple1 :: Program'
|
||||
simple1 = [coreProg|
|
||||
k a b = a;
|
||||
s f g x = f x (g x);
|
||||
@@ -115,6 +137,7 @@ simple1 = [coreProg|
|
||||
main = s k k 3;
|
||||
|]
|
||||
|
||||
caseBool1 :: Program'
|
||||
caseBool1 = [coreProg|
|
||||
_if c x y = case c of
|
||||
{ 1 -> x
|
||||
@@ -127,7 +150,8 @@ caseBool1 = [coreProg|
|
||||
main = _if false ((+#) 2 3) ((*#) 4 5);
|
||||
|]
|
||||
|
||||
factorialGM = [coreProg|
|
||||
fac3 :: Program'
|
||||
fac3 = [coreProg|
|
||||
fac n = case (==#) n 0 of
|
||||
{ 1 -> 1
|
||||
; 0 -> (*#) n (fac ((-#) n 1))
|
||||
@@ -136,6 +160,20 @@ factorialGM = [coreProg|
|
||||
main = fac 3;
|
||||
|]
|
||||
|
||||
-- TODO: paramaterised examples? eg. sumList could take a haskell list of ints
|
||||
-- as an input, translate it to a rl' list, and run the example on that?
|
||||
sumList :: Program'
|
||||
sumList = [coreProg|
|
||||
nil = Pack{0 0};
|
||||
cons x y = Pack{1 2} x y;
|
||||
list = cons 1 (cons 2 (cons 3 nil));
|
||||
sum l = case l of
|
||||
{ 0 -> 0
|
||||
; 1 x xs -> (+#) x (sum xs)
|
||||
};
|
||||
main = sum list;
|
||||
|]
|
||||
|
||||
corePrelude :: Module Name
|
||||
corePrelude = Module (Just ("Prelude", [])) $
|
||||
-- non-primitive defs
|
||||
|
||||
54
src/GM.hs
54
src/GM.hs
@@ -9,6 +9,10 @@ module GM
|
||||
( hdbgProg
|
||||
, evalProg
|
||||
, Node(..)
|
||||
, gmEvalProg
|
||||
, finalStateOf
|
||||
, resultOf
|
||||
, resultOfExpr
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -701,17 +705,12 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
|
||||
compileBinder (_ := v, a) = compileC g' v <> [Update a]
|
||||
|
||||
-- special cases for prim functions; essentially inlining
|
||||
compileE g ("negate#" :$ a) = compileE g a <> [Neg]
|
||||
compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b <> [Add]
|
||||
-- note that we only bother offsetting the environment and evaluationg
|
||||
-- in the "correct" order with non-commutative operations. if we
|
||||
-- implemented Sub the same way as Add, (-#) 3 2 would evaluate to -1.
|
||||
compileE g ("-#" :$ a :$ b) = compileE g b <> compileE g' a <> [Sub]
|
||||
where g' = argOffset 1 g
|
||||
compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b <> [Mul]
|
||||
compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g' b <> [Div]
|
||||
where g' = argOffset 1 g
|
||||
compileE g ("==#" :$ a :$ b) = compileE g a <> compileE g b <> [Equals]
|
||||
compileE g ("negate#" :$ a) = inlineOp1 g Neg a
|
||||
compileE g ("+#" :$ a :$ b) = inlineOp2 g Add a b
|
||||
compileE g ("-#" :$ a :$ b) = inlineOp2 g Sub a b
|
||||
compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul a b
|
||||
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
|
||||
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
|
||||
|
||||
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
|
||||
|
||||
@@ -728,6 +727,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
|
||||
g' = binds ++ argOffset n g
|
||||
c = compileE g' e
|
||||
|
||||
inlineOp1 :: Env -> Instr -> Expr' -> Code
|
||||
inlineOp1 g i a = compileE g a <> [i]
|
||||
|
||||
inlineOp2 :: Env -> Instr -> Expr' -> Expr' -> Code
|
||||
inlineOp2 g i a b = compileE g b <> compileE g' a <> [i]
|
||||
where g' = argOffset 1 g
|
||||
|
||||
-- | offset each address in the environment by n
|
||||
argOffset :: Int -> Env -> Env
|
||||
argOffset n = each . _2 %~ (+n)
|
||||
@@ -855,7 +861,7 @@ showNodeAtP p st a = case hLookup a h of
|
||||
name = case lookup a (swap <$> g) of
|
||||
Just (NameKey n) -> n
|
||||
Just (ConstrKey t n) -> idPack t n
|
||||
_ -> errTxtInvalidAddress
|
||||
_ -> errTxtInvalidAddress
|
||||
-- TODO: left-associativity
|
||||
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f
|
||||
<+> showNodeAtP (p+1) st x
|
||||
@@ -950,4 +956,26 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
|
||||
thread :: [a -> a] -> (a -> a)
|
||||
thread = appEndo . foldMap Endo
|
||||
|
||||
--}
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
gmEvalProg :: Program' -> GmState
|
||||
gmEvalProg p = compile p & eval & last
|
||||
|
||||
finalStateOf :: (GmState -> r) -> Program' -> r
|
||||
finalStateOf f = f . gmEvalProg
|
||||
|
||||
resultOf :: Program' -> Maybe Node
|
||||
resultOf p = do
|
||||
a <- res
|
||||
n <- hLookup a h
|
||||
pure n
|
||||
where
|
||||
res = st ^? gmStack . _head
|
||||
st = gmEvalProg p
|
||||
h = st ^. gmHeap
|
||||
|
||||
resultOfExpr :: Expr' -> Maybe Node
|
||||
resultOfExpr e = resultOf $ Program
|
||||
[ ScDef "main" [] e
|
||||
]
|
||||
|
||||
|
||||
Reference in New Issue
Block a user