diff --git a/Language/Nock5K/Repl.hs b/Language/Nock5K/Repl.hs --- a/Language/Nock5K/Repl.hs +++ b/Language/Nock5K/Repl.hs @@ -2,8 +2,8 @@ import Language.Nock5K.Parse import Language.Nock5K.Spec -import qualified Control.Exception as C import System.Console.Readline +import System.IO import Text.ParserCombinators.Parsec repl = do ln <- readline "nock " @@ -12,8 +12,10 @@ Just "exit" -> return () Just s -> do addHistory s case parse noun "" s of - Left e -> print e + Left e -> (sep . show) e Right n -> ep n repl - where - ep n = (print . nock) n `C.catch` (\e -> print (e :: C.SomeException)) + where ep n = case nock n of + Left e -> sep e + Right n -> print n + sep e = hPutStrLn stderr $ "error: " ++ e diff --git a/Language/Nock5K/Spec.lhs b/Language/Nock5K/Spec.lhs --- a/Language/Nock5K/Spec.lhs +++ b/Language/Nock5K/Spec.lhs @@ -1,5 +1,6 @@ > module Language.Nock5K.Spec where +> import Control.Monad.Instances 1 Structures @@ -7,13 +8,14 @@ A cell is an ordered pair of nouns. > data Noun = Atom Integer | Noun :- Noun deriving (Eq) +> type Comp = Either String 2 Reductions nock(a) *a -> nock :: Noun -> Noun +> nock :: Noun -> Comp Noun > nock = tar [a b c] [a [b c]] @@ -23,63 +25,68 @@ ?[a b] 0 -> wut (a :- b) = Atom 0 +> wut (a :- b) = return $ Atom 0 ?a 1 -> wut a = Atom 1 +> wut a = return $ Atom 1 +[a b] +[a b] -> lus (a :- b) = error "+[a b]" +> lus (a :- b) = Left "+[a b]" +a 1 + a -> lus (Atom a) = Atom (1 + a) +> lus (Atom a) = return $ Atom (1 + a) =[a a] 0 -> tis (a :- a') | a == a' = Atom 0 +> tis (a :- a') | a == a' = return $ Atom 0 =[a b] 1 -> tis (a :- b) = Atom 1 +> tis (a :- b) = return $ Atom 1 =a =a -> tis a = error "=a" +> tis a = Left "=a" /[1 a] a -> fas (Atom 1 :- a) = a +> fas (Atom 1 :- a) = return a /[2 a b] a -> fas (Atom 2 :- a :- b) = a +> fas (Atom 2 :- a :- b) = return a /[3 a b] b -> fas (Atom 3 :- a :- b) = b +> fas (Atom 3 :- a :- b) = return b /[(a + a) b] /[2 /[a b]] -> fas (Atom a :- b) | a > 2 && a `mod` 2 == 0 = -> fas $ Atom 2 :- fas (Atom (a `div` 2) :- b) +> fas (Atom a :- b) | a > 2 && a `mod` 2 == 0 = do +> x <- fas $ Atom (a `div` 2) :- b +> fas $ Atom 2 :- x /[(a + a + 1) b] /[3 /[a b]] -> fas (Atom a :- b) | a > 3 && a `mod` 2 == 1 = -> fas $ Atom 3 :- fas (Atom (a `div` 2) :- b) +> fas (Atom a :- b) | a > 3 && a `mod` 2 == 1 = do +> x <- fas $ Atom (a `div` 2) :- b +> fas $ Atom 3 :- x /a /a -> fas a = error "/a" +> fas a = Left "/a" *[a [b c] d] [*[a b c] *[a d]] -> tar (a :- (b :- c) :- d) = tar (a :- b :- c) :- tar (a :- d) +> tar (a :- (b :- c) :- d) = do +> x <- tar (a :- b :- c) +> y <- tar (a :- d) +> return $ x :- y *[a 0 b] /[b a] @@ -88,23 +95,26 @@ *[a 1 b] b -> tar (a :- (Atom 1 :- b)) = b +> tar (a :- (Atom 1 :- b)) = return b *[a 2 b c] *[*[a b] *[a c]] -> tar (a :- Atom 2 :- b :- c) = tar $ tar (a :- b) :- tar (a :- c) +> tar (a :- Atom 2 :- b :- c) = do +> x <- tar (a :- b) +> y <- tar (a :- c) +> tar $ x :- y *[a 3 b] ?*[a b] -> tar (a :- Atom 3 :- b) = (wut.tar) (a :- b) +> tar (a :- Atom 3 :- b) = tar (a :- b) >>= wut *[a 4 b] +*[a b] -> tar (a :- Atom 4 :- b) = (lus.tar) (a :- b) +> tar (a :- Atom 4 :- b) = tar (a :- b) >>= lus *[a 5 b] =*[a b] -> tar (a :- Atom 5 :- b) = (tis.tar) (a :- b) +> tar (a :- Atom 5 :- b) = tar (a :- b) >>= tis *[a 6 b c d] *[a 2 [0 1] 2 [1 c d] [1 0] 2 [1 2 3] [1 0] 4 4 b] @@ -141,4 +151,4 @@ *a *a -> tar a = error "*a" +> tar a = Left "*a" diff --git a/hsnock.cabal b/hsnock.cabal --- a/hsnock.cabal +++ b/hsnock.cabal @@ -1,5 +1,5 @@ name : hsnock -version : 0.2.0 +version : 0.3.1 category : Language license : PublicDomain synopsis : Nock 5K interpreter. diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -9,8 +9,6 @@ import Text.ParserCombinators.Parsec (parse) import Text.Printf -main = defaultMain tests - instance Arbitrary Noun where arbitrary = choose (0, 32) >>= arbD where @@ -18,37 +16,35 @@ arbD 0 = (Atom . abs) <$> arbitrary arbD n = do coin <- arbitrary if coin - then (Atom . abs) <$> arbitrary + then arbD 0 else (:-) <$> arbD (n - 1) <*> arbD (n - 1) -parsenoun n = case parse noun "" n of - Left e -> error "parse" - Right n -> n +pn n = case parse noun "" n of Right n -> n -prop_parse_show n = n == (parsenoun . show) n +prop_parse_show n = n == (pn . show) n -prop_dec a' = nock (Atom (a + 1) :- dec) == Atom a +prop_dec a' = nock (Atom (a + 1) :- dec) == (Right $ Atom a) where ds = "[8 [1 0] 8 [1 6 [5 [0 7] 4 0 6] [0 6] 9 2 [0 2] [4 0 6] 0 7] 9 2 0 1]" - dec = parsenoun ds + dec = pn ds a = abs a' -prop_6_is_if a' b = nock (ifs $ Atom 0) == Atom (a + 1) && nock (ifs $ Atom 1) == b +prop_6_is_if a' b = nock (ifs $ Atom 0) == Right (Atom (a + 1)) && nock (ifs $ Atom 1) == Right b where ifs c = Atom a :- Atom 6 :- (Atom 1 :- c) :- (Atom 4 :- Atom 0 :- Atom 1) :- (Atom 1 :- b) a = abs a' -test_hint_crash = - C.catch (nock bad `seq` assertFailure "Hint not evaluated") - (\e -> do let se = show (e :: C.ErrorCall) - if se == "/a" - then return () - else assertFailure $ "Exception: " ++ se) - where - bad = Atom 42 :- Atom 10 :- (Atom 0 :- Atom 0 :- Atom 2) :- Atom 0 :- Atom 1 +test_hint_crash = assert $ nock bad == Left "/a" + where bad = pn "[42 10 [0 0 2] 0 1]" +test_eval_strict = assert $ nock bad == Left "/a" + where bad = pn "[0 2 [0 2] 1 1 42]" + tests = [ testProperty "parse.show" prop_parse_show , testProperty "decrement" prop_dec , testProperty "6_is_if" prop_6_is_if , testCase "10_hint_crash" test_hint_crash + , testCase "eval_strict" test_eval_strict ] + +main = defaultMain tests