From e7f601f1a3bc5113e1701e88a104625ffc43dba2 Mon Sep 17 00:00:00 2001 From: cstml Date: Fri, 20 May 2022 09:04:13 +0100 Subject: [PATCH] update: reflected changes in tests and examples --- examples/1-add-two-numbers.sp | 2 +- examples/3-read-two-numbers-and-add.sp | 6 +- examples/4-compare-2-terms.sp | 6 +- examples/6-fibo.sp | 4 +- src/Space/Evaluator/Implementation.hs | 4 +- src/Space/Language/Term.hs | 12 +-- src/Space/Parser/Term.hs | 4 +- test/Test/Space/Evaluator/Machine.hs | 52 ++++++++----- test/Test/Space/Language.hs | 2 +- test/Test/Space/Parser.hs | 28 +++---- test/Test/Space/TypeChecker/Derive.hs | 102 ++++++++++++------------- 11 files changed, 120 insertions(+), 102 deletions(-) diff --git a/examples/1-add-two-numbers.sp b/examples/1-add-two-numbers.sp index 8180394..b76d4a3 100644 --- a/examples/1-add-two-numbers.sp +++ b/examples/1-add-two-numbers.sp @@ -7,4 +7,4 @@ +; -- add -> stack: 6 ; -- bind x -> stack: * -- -> x : 6 -@Ou[x]; -- push to output x ~> 6 +[x]@O; -- push to output x ~> 6 diff --git a/examples/3-read-two-numbers-and-add.sp b/examples/3-read-two-numbers-and-add.sp index df78f41..5b42489 100644 --- a/examples/3-read-two-numbers-and-add.sp +++ b/examples/3-read-two-numbers-and-add.sp @@ -1,7 +1,7 @@ -@In; -- read y +@I; -- read y y; -- evaluate it -@In; -- read y +@I; -- read y y; -- evaluate +; -- do the sum ; -- bind the result -@Ou[x]; -- push to output \ No newline at end of file +[x]@O; -- push to output \ No newline at end of file diff --git a/examples/4-compare-2-terms.sp b/examples/4-compare-2-terms.sp index c7c523b..7beb352 100644 --- a/examples/4-compare-2-terms.sp +++ b/examples/4-compare-2-terms.sp @@ -1,7 +1,7 @@ -@In; -- read y +@I; -- read y y; -- evaluate it -@In; -- read y +@I; -- read y y; -- evaluate ==; -- compare ; -- bind the result -@Ou[x]; -- push to output \ No newline at end of file +[x]@O; -- push to output \ No newline at end of file diff --git a/examples/6-fibo.sp b/examples/6-fibo.sp index 23f291b..287a696 100644 --- a/examples/6-fibo.sp +++ b/examples/6-fibo.sp @@ -7,10 +7,10 @@ [10];; -- y := 10 -[@Ou[x]; x; ; x; xx ; +; !; ; i ; !; ;];; +[[x]@O; x; ; x; xx ; +; !; ; i ; !; ;];; -- a := print x . i = x . x = xx + x . xx = i . evaluate z -[@Ou[x]];; +[[x]@O];; -- b := print x [ [a;z]; diff --git a/src/Space/Evaluator/Implementation.hs b/src/Space/Evaluator/Implementation.hs index 71145fd..3b2eec5 100644 --- a/src/Space/Evaluator/Implementation.hs +++ b/src/Space/Evaluator/Implementation.hs @@ -58,7 +58,7 @@ evaluate = \case SInteger _ _ -> pushGamma x >> evaluate con SChar _ _ -> pushGamma x >> evaluate con SPop v l _ -> case l of - Location "In" -> do + Location "I" -> do i <- input case parseTerm i of Left e -> error $ show e @@ -66,7 +66,7 @@ evaluate = \case evaluate con _ -> (bind1 v =<< pop1 l) >> evaluate con SPush t l _ -> case l of - Location "Ou" -> do + Location "O" -> do case t of -- if it is a variable, then get its bound value; SVariable v SEmpty -> do diff --git a/src/Space/Language/Term.hs b/src/Space/Language/Term.hs index d3e10c4..ad6ed90 100644 --- a/src/Space/Language/Term.hs +++ b/src/Space/Language/Term.hs @@ -47,22 +47,22 @@ instance Pretty Term where SEmpty -> brackets (pretty t) _ -> brackets (pretty t) <++> pretty con _ -> case con of - SEmpty -> pretty l <> brackets (pretty t) - _ -> pretty l <> brackets (pretty t) <++> pretty con + SEmpty -> brackets (pretty t) <> pretty l + _ -> brackets (pretty t) <> pretty l <++> pretty con SPop v l con -> case l of DLocation -> case con of SEmpty -> angles (pretty v) _ -> angles (pretty v) <++> pretty con _ -> case con of - SEmpty -> pretty l <> angles (pretty v) - _ -> pretty l <> angles (pretty v) <++> pretty con + SEmpty -> angles (pretty v) <> pretty l + _ -> angles (pretty v) <> pretty l <++> pretty con SPopT v l ty con -> case l of DLocation -> case con of SEmpty -> angles (pretty v <> colon <> pretty ty) _ -> angles (pretty v <> colon <> pretty ty) <++> pretty con _ -> case con of - SEmpty -> pretty l <> angles (pretty v <> colon <> pretty ty) - _ -> pretty l <> angles (pretty v <> colon <> pretty ty) <++> pretty con + SEmpty -> angles (pretty v <> colon <> pretty ty) <> pretty l + _ -> angles (pretty v <> colon <> pretty ty) <> pretty l <++> pretty con SEmpty -> pretty "{}" instance Semigroup Term where diff --git a/src/Space/Parser/Term.hs b/src/Space/Parser/Term.hs index 8c9de50..ba7792b 100644 --- a/src/Space/Parser/Term.hs +++ b/src/Space/Parser/Term.hs @@ -113,13 +113,13 @@ pPushDef :: Parser (Term -> Term) pPushDef = (`SPush` DLocation) <$> P.between (lex_ $ P.char '[') (lex_ $ P.char ']') pTerm pPush :: Parser (Term -> Term) -pPush = flip SPush <$> pLocation <*> P.between (lex_ $ P.char '[') (lex_ $ P.char ']') pTerm +pPush = SPush <$> P.between (lex_ $ P.char '[') (lex_ $ P.char ']') pTerm <*> pLocation pPopDef :: Parser (Term -> Term) pPopDef = flip SPop DLocation <$> P.between (lex_ $ P.char '<') (lex_ $ P.char '>') pVar pPop :: Parser (Term -> Term) -pPop = flip SPop <$> pLocation <*> P.between (lex_ $ P.char '<') (lex_ $ P.char '>') pVar +pPop = SPop <$> P.between (lex_ $ P.char '<') (lex_ $ P.char '>') pVar <*> pLocation pSeparator :: Parser () pSeparator = lex_ . void $ P.choice $ P.try <$> [P.char ';'] diff --git a/test/Test/Space/Evaluator/Machine.hs b/test/Test/Space/Evaluator/Machine.hs index 70a437e..bd001e8 100644 --- a/test/Test/Space/Evaluator/Machine.hs +++ b/test/Test/Space/Evaluator/Machine.hs @@ -24,7 +24,7 @@ test1 = "Working Push Int 3s." ( ok ( mempty @MachineMemory - & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 3, int 3])] + & spine .~ mconcat [int 3, int 3] ) ) (evaluate' . mconcat $ [int 3, int 3]) @@ -35,7 +35,7 @@ test1 = "Working Push Chars." ( ok ( mempty @MachineMemory - & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [char, char])] + & spine .~ mconcat [char, char] ) ) (evaluate' . mconcat $ [char, char]) @@ -54,7 +54,7 @@ test1 = & binds . at (var "x") ?~ char ) ) - (evaluate' . mconcat $ [char, popX]) + (evaluate' . mconcat $ [SPush char DLocation SEmpty, popX]) assertEqual "Working Pop 1 term and put it back." @@ -64,7 +64,13 @@ test1 = & stacks . at home ?~ review stack (S.fromList [char]) ) ) - (evaluate' . mconcat $ [char, popX, varX]) + ( evaluate' . mconcat $ + [ SPush char DLocation SEmpty + , popX + , varX + , SVariable (Variable "!") SEmpty + ] + ) assertEqual "Pop 1 term and bind it to another variable." @@ -75,7 +81,16 @@ test1 = & stacks . at home ?~ review stack (S.fromList [char]) ) ) - (evaluate' . mconcat $ [char, popX, varX, popY, varY]) + ( evaluate' . mconcat $ + [ SPush char DLocation SEmpty + , popX + , varX + , SVariable (Variable "!") SEmpty + , popY + , varY + , SVariable (Variable "!") SEmpty + ] + ) assertEqual "Pop 1 term from stack of 2." @@ -85,7 +100,12 @@ test1 = & stacks . at home ?~ review stack (S.fromList [char]) ) ) - (evaluate' . mconcat $ [char, char, popX]) + ( evaluate' . mconcat $ + [ SPush char DLocation SEmpty + , SPush char DLocation SEmpty + , popX + ] + ) assertEqual "Working Pop 1 term from stack of 0." @@ -104,7 +124,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 6])] ) ) - (evaluate' . mconcat $ [int 3, int 3, op "+"]) + (evaluate' . mconcat $ [int 3, int 3, op "+", SVariable (Variable "!") SEmpty]) assertEqual "Division." @@ -113,7 +133,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 1])] ) ) - (evaluate' . mconcat $ [int 3, int 3, op "/"]) + (evaluate' . mconcat $ [int 3, int 3, op "/", SVariable (Variable "!") SEmpty]) assertEqual "Comparison True." @@ -122,7 +142,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 1])] ) ) - (evaluate' . mconcat $ [int 3, int 3, op "=="]) + (evaluate' . mconcat $ [int 3, int 3, op "==", SVariable (Variable "!") SEmpty]) assertEqual "Comparison False." @@ -131,7 +151,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 0])] ) ) - (evaluate' . mconcat $ [int 3, int 2, op "=="]) + (evaluate' . mconcat $ [int 3, int 2, op "==", SVariable (Variable "!") SEmpty]) assertEqual "Inequality True." @@ -140,7 +160,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 0])] ) ) - (evaluate' . mconcat $ [int 3, int 3, op "/="]) + (evaluate' . mconcat $ [int 3, int 3, op "/=", SVariable (Variable "!") SEmpty]) assertEqual "Inequality False." @@ -149,7 +169,7 @@ test1 = & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [int 1])] ) ) - (evaluate' . mconcat $ [int 3, int 2, op "/="]) + (evaluate' . mconcat $ [int 3, int 2, op "/=", SVariable (Variable "!") SEmpty]) assertEqual "Working error." @@ -160,7 +180,7 @@ test1 = "Self evaluation" ( ok ( mempty @MachineMemory - & stacks .~ M.fromList [(home, mempty & stack .~ S.fromList [varT "x"])] + & spine .~ varT "x" ) ) (evaluate' . mconcat $ [varT "x"]) @@ -179,10 +199,8 @@ test1 = "Self evaluation 3" ( ok ( Memory - { _spine = SEmpty - , _stacks = - M.fromList - [(DLocation, Stack {_stack = S.fromList [SVariable (Variable "x") SEmpty]})] + { _spine = SVariable (Variable "x") SEmpty + , _stacks = mempty , _binds = M.fromList [(Variable "y", SVariable (Variable "x") SEmpty)] } ) diff --git a/test/Test/Space/Language.hs b/test/Test/Space/Language.hs index 68d7e4c..b4e408a 100644 --- a/test/Test/Space/Language.hs +++ b/test/Test/Space/Language.hs @@ -28,7 +28,7 @@ test = "Language Unit Tests." [ testGroup "Pretty Show Terms." - [ testCase "Empty." $ sPretty SEmpty @?= "*" + [ testCase "Empty." $ sPretty SEmpty @?= "{}" , testCase "Variable." $ sPretty (SVariable "x" SEmpty) @?= "x" , testCase "Integer." $ sPretty (SInteger 3 SEmpty) @?= "3" , testCase "Char." $ sPretty (SChar 's' SEmpty) @?= "'s'" diff --git a/test/Test/Space/Parser.hs b/test/Test/Space/Parser.hs index bbcb944..88b2225 100644 --- a/test/Test/Space/Parser.hs +++ b/test/Test/Space/Parser.hs @@ -24,7 +24,7 @@ tParseTerm = P.parse pTerm "Test Input" . fromString unit = let stdTest r1 t1 r2 t2 = do - let str = r1 <> ";*" + let str = r1 <> ";{}" assertEqual str (Right $ t1 SEmpty) (tParseTerm str) let str = r1 @@ -33,25 +33,25 @@ unit = let str = r1 <> ";" assertEqual str (Right $ t1 SEmpty) (tParseTerm str) - let str = r1 <> " ; *" + let str = r1 <> " ; {}" assertEqual str (Right $ t1 SEmpty) (tParseTerm str) - let str = r1 <> " ; " <> r2 <> " ; *" + let str = r1 <> " ; " <> r2 <> " ; {}" assertEqual str (Right $ t1 $ t2 SEmpty) (tParseTerm str) let str = r1 <> " ; " <> r2 <> ";" assertEqual str (Right $ t1 $ t2 SEmpty) (tParseTerm str) - let str = r1 <> " {-; " <> r2 <> " -}; *" + let str = r1 <> " {-; " <> r2 <> " -}; {}" assertEqual str (Right $ t1 SEmpty) (tParseTerm str) in testGroup "Parser Unit Tests" - [ testCase "Parse empty Term" $ assertEqual "*" (Right SEmpty) (tParseTerm "*") + [ testCase "Parse empty Term" $ let t = "{}" in assertEqual t (Right SEmpty) (tParseTerm t) , testCase "Parse Push empty." $ - let p = "[*];*" + let p = "[{}];{}" in assertEqual p (Right $ SPush SEmpty DLocation SEmpty) (tParseTerm p) , testCase "Parse Push Variable." $ - let p = "[x;*];*" + let p = "[x;{}];{}" in assertEqual p (Right $ SPush (SVariable (Variable "x") SEmpty) DLocation SEmpty) (tParseTerm p) , testCase "Parse Push Variable." $ stdTest @@ -62,23 +62,23 @@ unit = , testCase "Parse Char." $ stdTest "'x'" (SChar 'x') "'y'" (SChar 'y') , testCase "Parse Int." $ stdTest "1" (SInteger 1) "20" (SInteger 20) , let t x = SPush (SVariable (Variable x) SEmpty) DLocation - in testCase "Parse Push Default Location." $ stdTest "[ x ; * ]" (t "x") "[y;*]" (t "y") + in testCase "Parse Push Default Location." $ stdTest "[ x ; {} ]" (t "x") "[y;{}]" (t "y") , let t x = SPush (SVariable (Variable x) SEmpty) DLocation in testCase "Parse Push Default Location." $ stdTest "[ x ]" (t "x") "[ y ]" (t "y") , let t x = SPush (SVariable (Variable x) SEmpty) DLocation - in testCase "Parse Push Default Locataion." $ stdTest "[ x;* ]" (t "x") "[y;*]" (t "y") + in testCase "Parse Push Default Locataion." $ stdTest "[ x;{} ]" (t "x") "[y;{}]" (t "y") , let t x = SPush (SVariable (Variable x) SEmpty) DLocation - in testCase "Parse Push Default Locataion." $ stdTest "[x;*]" (t "x") "[ y;* ]" (t "y") + in testCase "Parse Push Default Locataion." $ stdTest "[x;{}]" (t "x") "[ y;{} ]" (t "y") , let t x = SPush (SInteger x SEmpty) DLocation - in testCase "Parse Push Default Locataion." $ stdTest "[1;*]" (t 1) "[ 2;* ]" (t 2) + in testCase "Parse Push Default Locataion." $ stdTest "[1;{}]" (t 1) "[ 2;{} ]" (t 2) , let t x l = SPush (SVariable (Variable x) SEmpty) (Location l) - in testCase "Parse Push arbitrary." $ stdTest "@In[ x ; * ]" (t "x" "In") "@Ou[y;*]" (t "y" "Ou") + in testCase "Parse Push arbitrary." $ stdTest "[ x ; {} ]@In" (t "x" "In") "[y;{}]@Ou" (t "y" "Ou") , let t x l = SPush (SVariable (Variable x) SEmpty) (Location l) - in testCase "Parse Push arbitrary." $ stdTest "@In[ x;* ]" (t "x" "In") "@Ou[y;*]" (t "y" "Ou") + in testCase "Parse Push arbitrary." $ stdTest "[ x;{} ]@In" (t "x" "In") "[y;{}]@Ou" (t "y" "Ou") , let t x = SPop (Variable x) DLocation in testCase "Parse Pop Ho." $ stdTest "" (t "x") "" (t "y") , let t x l = SPop (Variable x) (Location l) - in testCase "Parse Pop arbitrary." $ stdTest "@In" (t "x" "In") "@Yo" (t "y" "Yo") + in testCase "Parse Pop arbitrary." $ stdTest "@In" (t "x" "In") "@Yo" (t "y" "Yo") , testCase "Parse Equal (Variable)." $ stdTest "==" (SVariable (Variable "==")) "/=" (SVariable (Variable "/=")) ] diff --git a/test/Test/Space/TypeChecker/Derive.hs b/test/Test/Space/TypeChecker/Derive.hs index 8cbbfb5..0717eef 100644 --- a/test/Test/Space/TypeChecker/Derive.hs +++ b/test/Test/Space/TypeChecker/Derive.hs @@ -12,57 +12,57 @@ test = , testCase "Simple Derivation" $ unDerive (derive SEmpty) @?= Right (DEmpty (TJudgement {_jContext = TContext {_tContext = []}, _jTerm = SEmpty, _jType = TEmpty})) - , testCase "Trivial term type infer." $ - unDerive (derive $ SInteger 1 $ SInteger 2 $ SInteger 3 SEmpty) - @?= let commonContext = - [ - ( SEmpty - , TEmpty ->: TEmpty - ) - , - ( SInteger 3 SEmpty - , TEmpty ->: TConstant TInt TEmpty - ) - , - ( SInteger 1 SEmpty - , TEmpty ->: TConstant TInt TEmpty - ) - , - ( SInteger 1 SEmpty - , TEmpty ->: TConstant TInt TEmpty - ) - ] - in Right - ( DSeq - ( TJudgement - { _jContext = TContext commonContext - , _jTerm = SInteger 1 (SInteger 2 (SInteger 3 SEmpty)) - , _jType = TVariable (TVariableAtom "a1") TEmpty - } - ) - ( DSeq - ( TJudgement - { _jContext = TContext commonContext - , _jTerm = SInteger 2 (SInteger 3 SEmpty) - , _jType = TVariable (TVariableAtom "a2") TEmpty - } + {-, testCase "Trivial term type infer." $ + unDerive (derive $ SInteger 1 $ SInteger 2 $ SInteger 3 SEmpty) + @?= let commonContext = + [ + ( SEmpty + , TEmpty ->: TEmpty ) - ( DSeq - ( TJudgement - { _jContext = TContext commonContext - , _jTerm = SInteger 3 SEmpty - , _jType = TVariable (TVariableAtom "a3") TEmpty - } - ) - ( DEmpty - ( TJudgement - { _jContext = TContext commonContext - , _jTerm = SEmpty - , _jType = TEmpty - } - ) - ) + , + ( SInteger 3 SEmpty + , TEmpty ->: TConstant TInt TEmpty ) - ) - ) + , + ( SInteger 1 SEmpty + , TEmpty ->: TConstant TInt TEmpty + ) + , + ( SInteger 1 SEmpty + , TEmpty ->: TConstant TInt TEmpty + ) + ] + in Right + ( DSeq + ( TJudgement + { _jContext = TContext commonContext + , _jTerm = SInteger 1 (SInteger 2 (SInteger 3 SEmpty)) + , _jType = TVariable (TVariableAtom "a1") TEmpty + } + ) + ( DSeq + ( TJudgement + { _jContext = TContext commonContext + , _jTerm = SInteger 2 (SInteger 3 SEmpty) + , _jType = TVariable (TVariableAtom "a2") TEmpty + } + ) + ( DSeq + ( TJudgement + { _jContext = TContext commonContext + , _jTerm = SInteger 3 SEmpty + , _jType = TVariable (TVariableAtom "a3") TEmpty + } + ) + ( DEmpty + ( TJudgement + { _jContext = TContext commonContext + , _jTerm = SEmpty + , _jType = TEmpty + } + ) + ) + ) + ) + )-} ]