commit 1ec86b420ba40f49bc45946647ba00a50828142a
parent 2e24df5c9e3c4f15e3814220a5a586d5c49d3d0f
Author: Jared Tobin <jared@jtobin.ca>
Date: Fri, 13 Jul 2018 13:27:21 +1200
Make less sucky.
Diffstat:
5 files changed, 162 insertions(+), 166 deletions(-)
diff --git a/lib/Nock/Eval.hs b/lib/Nock/Eval.hs
@@ -1,153 +1,150 @@
-
module Nock.Eval (
nock
+ , eval
) where
+import Control.Monad ((<=<))
import Nock.Language
-nock :: Expr -> Noun
-nock expr = case expr of
- Noun noun -> noun
- Pair l r -> Cell (nock l) (nock r)
- Wut e -> wut (nock e)
- Lus e -> lus (nock e)
- Tis e -> tis (nock e)
- Fas e -> fas (nock e)
- Tar e -> tar (nock e)
-
-wut :: Noun -> Noun
-wut noun = case noun of
+data Error = Error Noun
+ deriving Show
+
+type Possibly = Either Error
+
+nock :: Noun -> Possibly Noun
+nock = tar
+
+eval :: Expr -> Possibly Noun
+eval expr = case expr of
+ Noun noun -> return noun
+ Wut e -> wut e
+ Lus e -> lus e
+ Tis e -> tis e
+ Fas e -> fas e
+ Tar e -> tar e
+
+wut :: Noun -> Possibly Noun
+wut noun = return $ case noun of
Cell {} -> Atom 0
Atom {} -> Atom 1
-lus :: Noun -> Noun
+lus :: Noun -> Possibly Noun
lus noun = case noun of
- Cell {} -> error "lus: bad noun"
- Atom m -> Atom (1 + m)
+ Cell {} -> Left (Error noun)
+ Atom m -> return (Atom (1 + m))
-tis :: Noun -> Noun
+tis :: Noun -> Possibly Noun
tis noun = case noun of
- Atom {} -> error "tis: bad noun"
- Cell m n ->
+ Atom {} -> Left (Error noun)
+ Cell m n -> return $
if m == n
then Atom 0
else Atom 1
-fas :: Noun -> Noun
+fas :: Noun -> Possibly Noun
fas noun = case noun of
- Atom {} -> error "fas: bad noun"
- Cell m n -> case m of
- Cell {} -> error "fas: bad noun"
- Atom a -> case a of
-
- 1 -> n
-
- 2 -> case n of
- Atom {} -> error "fas: bad noun"
- Cell o _ -> o
-
- 3 -> case n of
- Atom {} -> error "fas: bad noun"
- Cell _ o -> o
-
- _ ->
- if even a
- then
- let inner = Cell (Atom (a `div` 2)) n
- in fas (Cell (Atom 2) (fas inner))
- else
- let inner = Cell (Atom ((a - 1) `div` 2)) n
- in fas (Cell (Atom 3) (fas inner))
-
-tar :: Noun -> Noun
+ Cell (Atom 1) a -> return a
+ Cell (Atom 2) (Cell a _) -> return a
+ Cell (Atom 3) (Cell _ b) -> return b
+ Cell (Atom a) b ->
+ if even a
+ then do
+ inner <- fas (Cell (Atom (a `div` 2)) b)
+ fas (Cell (Atom 2) inner)
+ else do
+ inner <- fas (Cell (Atom ((a - 1) `div` 2)) b)
+ fas (Cell (Atom 3) inner)
+
+ _ -> Left (Error noun)
+
+tar :: Noun -> Possibly Noun
tar noun = case noun of
- Atom {} -> error "tar: bad noun"
- Cell a m -> case m of
- Atom {} -> error "tar: bad noun"
- Cell n d -> case n of
- Cell b c -> Cell (tar (Cell a (Cell b c))) (tar (Cell a d))
- Atom z -> case z of
+ Cell a (Cell (Cell b c) d) -> do
+ inner0 <- tar (Cell a (Cell b c))
+ inner1 <- tar (Cell a d)
+ return (Cell inner0 inner1)
+
+ Cell a (Cell (Atom 0) b) ->
+ fas (Cell b a)
- 0 -> fas (Cell d a)
+ Cell _ (Cell (Atom 1) b) ->
+ return b
- 1 -> d
+ Cell a (Cell (Atom 2) (Cell b c)) -> do
+ inner0 <- tar (Cell a b)
+ inner1 <- tar (Cell a c)
+ tar (Cell inner0 inner1)
- 2 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell e f ->
- tar (Cell (tar (Cell a e)) (tar (Cell a f)))
+ Cell a (Cell (Atom 3) b) ->
+ let wuttar = wut <=< tar
+ in wuttar (Cell a b)
- 3 -> wut (tar (Cell a d))
+ Cell a (Cell (Atom 4) b) ->
+ let lustar = lus <=< tar
+ in lustar (Cell a b)
- 4 -> lus (tar (Cell a d))
+ Cell a (Cell (Atom 5) b) ->
+ let tistar = tis <=< tar
+ in tistar (Cell a b)
- 5 -> tis (tar (Cell a d))
+ Cell a (Cell (Atom 6) (Cell b (Cell c d))) ->
+ tar (tar6 a b c d)
- 6 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell g h -> case h of
- Atom {} -> error "tar: bad noun"
- Cell i j -> tar (tar6 a g i j)
+ Cell a (Cell (Atom 7) (Cell b c)) ->
+ tar (Cell a (Cell (Atom 2) (Cell b (Cell (Atom 1) c))))
- 7 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell g h ->
- tar (Cell a (Cell (Atom 2) (Cell g (Cell (Atom 1) h))))
+ Cell a (Cell (Atom 8) (Cell b c)) ->
+ tar (tar8 a b c)
- 8 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell g h -> tar (tar8 a g h)
+ Cell a (Cell (Atom 9) (Cell b c)) ->
+ tar (tar9 a b c)
- 9 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell g h -> tar (tar9 a g h)
+ Cell a (Cell (Atom 10) (Cell (Cell b c) d)) ->
+ tar (tar10 a b c d)
- 10 -> case d of
- Atom {} -> error "tar: bad noun"
- Cell g h -> case g of
- Cell i j -> tar (tar10 a i j h)
- _ -> tar (Cell a h)
+ Cell a (Cell (Atom 10) (Cell _ c)) ->
+ tar (Cell a c)
- _ -> error "tar: bad noun"
+ _ -> Left (Error noun)
tar6 :: Noun -> Noun -> Noun -> Noun -> Noun
tar6 a b c d =
Cell a
(Cell (Atom 2)
- (Cell (Cell (Atom 0) (Atom 1))
- (Cell (Atom 2)
- (Cell (Cell (Atom 1) (Cell c d))
- (Cell (Cell (Atom 1) (Atom 0))
- (Cell (Atom 2)
- (Cell (Cell (Atom 1) (Cell (Atom 2) (Atom 3)))
- (Cell (Cell (Atom 1) (Atom 0))
- (Cell (Atom 4)
- (Cell (Atom 4) b))))))))))
+ (Cell (Cell (Atom 0) (Atom 1))
+ (Cell (Atom 2)
+ (Cell (Cell (Atom 1) (Cell c d))
+ (Cell (Cell (Atom 1) (Atom 0))
+ (Cell (Atom 2)
+ (Cell (Cell (Atom 1) (Cell (Atom 2) (Atom 3)))
+ (Cell (Cell (Atom 1) (Atom 0))
+ (Cell (Atom 4)
+ (Cell (Atom 4) b))))))))))
tar8 :: Noun -> Noun -> Noun -> Noun
tar8 a b c =
Cell a
(Cell (Atom 7)
- (Cell
- (Cell (Atom 7)
- (Cell (Cell (Atom 0) (Atom 1)) b))
- (Cell (Cell (Atom 0) (Atom 1)) c)))
+ (Cell
+ (Cell (Atom 7)
+ (Cell (Cell (Atom 0) (Atom 1)) b))
+ (Cell (Cell (Atom 0) (Atom 1)) c)))
tar9 :: Noun -> Noun -> Noun -> Noun
tar9 a b c =
Cell a
(Cell (Atom 7)
- (Cell c
- (Cell (Atom 2)
- (Cell (Cell (Atom 0) (Atom 1))
- (Cell (Atom 0) b)))))
+ (Cell c
+ (Cell (Atom 2)
+ (Cell (Cell (Atom 0) (Atom 1))
+ (Cell (Atom 0) b)))))
tar10 :: Noun -> Noun -> Noun -> Noun -> Noun
tar10 a _ c d =
Cell a
(Cell (Atom 8)
- (Cell c
- (Cell (Atom 7)
- (Cell (Cell (Atom 0) (Atom 3))
- d))))
+ (Cell c
+ (Cell (Atom 7)
+ (Cell (Cell (Atom 0) (Atom 3))
+ d))))
diff --git a/lib/Nock/Language.hs b/lib/Nock/Language.hs
@@ -1,4 +1,3 @@
-
module Nock.Language (
Noun(..)
, Expr(..)
@@ -16,21 +15,19 @@ instance Show Noun where
data Expr =
Noun !Noun
- | Pair Expr Expr
- | Wut Expr
- | Lus Expr
- | Tis Expr
- | Fas Expr
- | Tar Expr
+ | Wut !Noun
+ | Lus !Noun
+ | Tis !Noun
+ | Fas !Noun
+ | Tar !Noun
deriving Eq
instance Show Expr where
show op = case op of
- Noun n -> show n
- Pair l r -> mconcat ["[", show l, " ", show r, "]"]
- Wut n -> mconcat ["?", show n]
- Lus n -> mconcat ["+", show n]
- Tis n -> mconcat ["=", show n]
- Fas n -> mconcat ["/", show n]
- Tar n -> mconcat ["*", show n]
+ Noun n -> show n
+ Wut n -> mconcat ["?", show n]
+ Lus n -> mconcat ["+", show n]
+ Tis n -> mconcat ["=", show n]
+ Fas n -> mconcat ["/", show n]
+ Tar n -> mconcat ["*", show n]
diff --git a/lib/Nock/Parse.hs b/lib/Nock/Parse.hs
@@ -16,52 +16,56 @@ parse = P.runParser expr [] "input"
expr :: Monad m => P.ParsecT T.Text u m Expr
expr =
P.try operator
- <|> P.try cell
+ <|> fmap Noun noun
+
+operator :: Monad m => P.ParsecT T.Text u m Expr
+operator = do
+ op <- P.oneOf "?+=/*"
+ case op of
+ '?' -> fmap Wut noun
+ '+' -> fmap Lus noun
+ '=' -> fmap Tis noun
+ '/' -> fmap Fas noun
+ '*' -> fmap Tar noun
+ _ -> fail "op: bad token"
+
+noun :: Monad m => P.ParsecT T.Text u m Noun
+noun =
+ P.try cell
<|> atom
-atom :: Monad m => P.ParsecT T.Text u m Expr
+atom :: Monad m => P.ParsecT T.Text u m Noun
atom = do
digits <- P.many P.digit
case digits of
(h:t) -> case h of
'0' -> case t of
- [] -> return (Noun (Atom 0))
+ [] -> return (Atom 0)
_ -> fail "atom: bad parse"
_ ->
let nat = read digits
- in return (Noun (Atom nat))
+ in return (Atom nat)
[] -> fail "atom: bad parse"
-operator :: Monad m => P.ParsecT T.Text u m Expr
-operator = do
- op <- P.oneOf "?+=/*"
- case op of
- '?' -> fmap Wut expr
- '+' -> fmap Lus expr
- '=' -> fmap Tis expr
- '/' -> fmap Fas expr
- '*' -> fmap Tar expr
- _ -> fail "op: bad token"
-
-cell :: Monad m => P.ParsecT T.Text u m Expr
+cell :: Monad m => P.ParsecT T.Text u m Noun
cell = do
P.char '['
P.skipMany P.space
- leader <- expr
+ leader <- noun
P.skipMany P.space
- rest <- P.sepBy expr (P.many1 P.space)
+ rest <- P.sepBy noun (P.many1 P.space)
P.skipMany P.space
P.char ']'
- return (toPair (leader : rest))
+ return (toCell (leader : rest))
-toPair :: [Expr] -> Expr
-toPair = loop where
+toCell :: [Noun] -> Noun
+toCell = loop where
loop list = case list of
[] -> error "cell: bad parse"
[_] -> error "cell: bad parse"
- [s, f] -> Pair s f
- (h:t) -> Pair h (loop t)
+ [s, f] -> Cell s f
+ (h:t) -> Cell h (loop t)
diff --git a/src/Main.hs b/src/Main.hs
@@ -16,9 +16,9 @@ main = do
T.putStrLn "USAGE: echo EXPR | ./hnock"
exitSuccess
- let parsed = parse input
-
- case parsed of
- Left err -> T.putStrLn (T.pack (show err))
- Right expr -> T.putStrLn (T.pack (show (nock expr)))
+ case parse input of
+ Left parseErr -> T.putStrLn (T.pack (show parseErr))
+ Right expr -> case eval expr of
+ Left err -> T.putStrLn (T.pack (show err))
+ Right noun -> T.putStrLn (T.pack (show noun))
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,4 +1,3 @@
-
module Main where
import Nock
@@ -8,9 +7,9 @@ import Nock
expr0 :: Expr
expr0 =
Fas
- (Noun (Cell (Atom 3)
+ (Cell (Atom 3)
(Cell (Cell (Atom 4) (Atom 5))
- (Cell (Atom 6) (Cell (Atom 14) (Atom 15))))))
+ (Cell (Atom 6) (Cell (Atom 14) (Atom 15)))))
noun0 :: Noun
noun0 = Cell (Atom 6) (Cell (Atom 14) (Atom 15))
@@ -20,10 +19,10 @@ noun0 = Cell (Atom 6) (Cell (Atom 14) (Atom 15))
expr1 :: Expr
expr1 =
Tar
- (Noun (Cell
+ (Cell
(Cell (Cell (Atom 4) (Atom 5))
(Cell (Atom 6) (Cell (Atom 14) (Atom 15))))
- (Cell (Atom 0) (Atom 7))))
+ (Cell (Atom 0) (Atom 7)))
noun1 :: Noun
noun1 = Cell (Atom 14) (Atom 15)
@@ -33,8 +32,8 @@ noun1 = Cell (Atom 14) (Atom 15)
expr2 :: Expr
expr2 =
Tar
- (Noun (Cell (Atom 42)
- (Cell (Atom 1) (Cell (Atom 153) (Atom 218)))))
+ (Cell (Atom 42)
+ (Cell (Atom 1) (Cell (Atom 153) (Atom 218))))
noun2 :: Noun
noun2 = Cell (Atom 153) (Atom 218)
@@ -44,9 +43,9 @@ noun2 = Cell (Atom 153) (Atom 218)
expr3 :: Expr
expr3 =
Tar
- (Noun (Cell (Atom 57)
+ (Cell (Atom 57)
(Cell (Atom 4)
- (Cell (Atom 0) (Atom 1)))))
+ (Cell (Atom 0) (Atom 1))))
noun3 :: Noun
noun3 = Atom 58
@@ -56,9 +55,9 @@ noun3 = Atom 58
expr4 :: Expr
expr4 =
Tar
- (Noun (Cell (Cell (Atom 132) (Atom 19))
+ (Cell (Cell (Atom 132) (Atom 19))
(Cell (Atom 4)
- (Cell (Atom 0) (Atom 3)))))
+ (Cell (Atom 0) (Atom 3))))
noun4 :: Noun
noun4 = Atom 20
@@ -68,9 +67,9 @@ noun4 = Atom 20
expr5 :: Expr
expr5 =
Fas
- (Noun (Cell (Atom 7)
+ (Cell (Atom 7)
(Cell (Cell (Atom 4) (Atom 5))
- (Cell (Atom 6) (Cell (Atom 14) (Atom 15))))))
+ (Cell (Atom 6) (Cell (Atom 14) (Atom 15)))))
noun5 :: Noun
noun5 = Cell (Atom 14) (Atom 15)
@@ -80,24 +79,23 @@ noun5 = Cell (Atom 14) (Atom 15)
expr6 :: Expr
expr6 =
Tar
- (Noun
(Cell (Atom 77)
(Cell (Atom 2)
(Cell (Cell (Atom 1) (Atom 42))
(Cell (Atom 1)
(Cell (Atom 1)
- (Cell (Atom 153) (Atom 218))))))))
+ (Cell (Atom 153) (Atom 218)))))))
noun6 :: Noun
noun6 = Cell (Atom 153) (Atom 218)
main :: IO ()
main = do
- print (nock expr0 == noun0)
- print (nock expr1 == noun1)
- print (nock expr2 == noun2)
- print (nock expr3 == noun3)
- print (nock expr4 == noun4)
- print (nock expr5 == noun5)
- print (nock expr6 == noun6)
+ print (fmap (== noun0) (eval expr0))
+ print (fmap (== noun1) (eval expr1))
+ print (fmap (== noun2) (eval expr2))
+ print (fmap (== noun3) (eval expr3))
+ print (fmap (== noun4) (eval expr4))
+ print (fmap (== noun5) (eval expr5))
+ print (fmap (== noun6) (eval expr6))
