1
exercism fetch haskell forth

test/Tests.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
{-# LANGUAGE OverloadedStrings #-}

import Control.Monad     (foldM)
import Test.Hspec        (Spec, describe, it, shouldBe)
import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)

import Forth (ForthError(..), empty, evalText, toList)

main :: IO ()
main = hspecWith defaultConfig {configFastFail = True} specs

specs :: Spec
specs = do

    let runTexts = fmap toList . foldM (flip evalText) empty

    describe "parsing and numbers" $
      it "numbers just get pushed onto the stack" $
        runTexts ["1 2 3 4 5"] `shouldBe` Right [1, 2, 3, 4, 5]

    describe "addition" $ do
      it "can add two numbers" $
        runTexts ["1 2 +"] `shouldBe` Right [3]
      it "errors if there is nothing on the stack" $
        runTexts ["+"] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 +"] `shouldBe` Left StackUnderflow

    describe "subtraction" $ do
      it "can subtract two numbers" $
        runTexts ["3 4 -"] `shouldBe` Right [-1]
      it "errors if there is nothing on the stack" $
        runTexts ["-"] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 -"] `shouldBe` Left StackUnderflow

    describe "multiplication" $ do
      it "can multiply two numbers" $
        runTexts ["2 4 *"] `shouldBe` Right [8]
      it "errors if there is nothing on the stack" $
        runTexts ["*"] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 *"] `shouldBe` Left StackUnderflow

    describe "division" $ do
      it "can divide two numbers" $
        runTexts ["12 3 /"] `shouldBe` Right [4]
      it "performs integer division" $
        runTexts ["8 3 /"] `shouldBe` Right [2]
      it "errors if dividing by zero" $
        runTexts ["4 0 /"] `shouldBe` Left DivisionByZero
      it "errors if there is nothing on the stack" $
        runTexts ["/"] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 /"] `shouldBe` Left StackUnderflow

    describe "combined arithmetic" $ do
      it "addition and subtraction" $
        runTexts ["1 2 + 4 -"] `shouldBe` Right [-1]

      it "multiplication and division" $
        runTexts ["2 4 * 3 /"] `shouldBe` Right [2]

    describe "dup" $ do
      it "copies a value on the stack" $
        runTexts ["1 dup"  ] `shouldBe` Right [1, 1]
      it "copies the top value on the stack" $
        runTexts ["1 2 dup"] `shouldBe` Right [1, 2, 2]
      it "errors if there is nothing on the stack" $
        runTexts ["dup"    ] `shouldBe` Left StackUnderflow

    describe "drop" $ do
      it "removes the top value on the stack if it is the only one" $
        runTexts ["1 drop"  ] `shouldBe` Right []
      it "removes the top value on the stack if it is not the only one" $
        runTexts ["1 2 drop"] `shouldBe` Right [1]
      it "errors if there is nothing on the stack" $
        runTexts ["drop"    ] `shouldBe` Left StackUnderflow

    describe "swap" $ do
      it "swaps the top two values on the stack if they are the only ones" $
        runTexts ["1 2 swap"  ] `shouldBe` Right [2, 1]
      it "swaps the top two values on the stack if they are not the only ones" $
        runTexts ["1 2 3 swap"] `shouldBe` Right [1, 3, 2]
      it "errors if there is nothing on the stack" $
        runTexts ["swap"      ] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 swap"    ] `shouldBe` Left StackUnderflow

    describe "over" $ do
      it "copies the second element if there are only two" $
        runTexts ["1 2 over"  ] `shouldBe` Right [1, 2, 1]
      it "copies the second element if there are more than two" $
        runTexts ["1 2 3 over"] `shouldBe` Right [1, 2, 3, 2]
      it "errors if there is nothing on the stack" $
        runTexts ["over"      ] `shouldBe` Left StackUnderflow
      it "errors if there is only one value on the stack" $
        runTexts ["1 over"    ] `shouldBe` Left StackUnderflow

    describe "user-defined words" $ do
      it "can consist of built-in words" $
        runTexts [ ": dup-twice dup dup ;"
                 , "1 dup-twice"           ] `shouldBe` Right [1, 1, 1]

      it "execute in the right order" $
        runTexts [ ": countup 1 2 3 ;"
                 , "countup"           ] `shouldBe` Right [1, 2, 3]

      it "can override other user-defined words" $
        runTexts [ ": foo dup ;"
                 , ": foo dup dup ;"
                 , "1 foo"           ] `shouldBe` Right [1, 1, 1]

      it "can override built-in words" $
        runTexts [ ": swap dup ;"
                 , "1 swap"       ] `shouldBe` Right [1, 1]

      it "can override built-in operators" $
        runTexts [ ": + * ;"
                 , "3 4 +"   ] `shouldBe` Right [12]

      it "cannot redefine numbers" $
        runTexts [": 1 2 ;"] `shouldBe` Left InvalidWord

      it "errors if executing a non-existent word" $
        runTexts ["1 foo"] `shouldBe` Left (UnknownWord "foo")

    describe "case-insensitivity" $ do
      it "DUP is case-insensitive" $
        runTexts ["1 DUP Dup dup"         ] `shouldBe` Right [1, 1, 1, 1]
      it "DROP is case-insensitive" $
        runTexts ["1 2 3 4 DROP Drop drop"] `shouldBe` Right [1]
      it "SWAP is case-insensitive" $
        runTexts ["1 2 SWAP 3 Swap 4 swap"] `shouldBe` Right [2, 3, 4, 1]
      it "OVER is case-insensitive" $
        runTexts ["1 2 OVER Over over"    ] `shouldBe` Right [1, 2, 1, 2, 1]

      it "user-defined words are case-insensitive" $
        runTexts [ ": foo dup ;"
                 , "1 FOO Foo foo" ] `shouldBe` Right [1, 1, 1, 1]

      it "definitions are case-insensitive" $
        runTexts [ ": SWAP DUP Dup dup ;"
                 , "1 swap"               ] `shouldBe` Right [1, 1, 1, 1]