4 files changed, 158 insertions, 0 deletions
diff --git a/src/K/Ast.hs b/src/K/Ast.hs
new file mode 100644
index 0000000..56761f5
--- /dev/null
+++ b/src/K/Ast.hs
@@ -0,0 +1,11 @@
+module K.Ast where
+
+data Expr
+    = Tru
+    | Fals
+    | Zero
+    | IsZero Expr
+    | Succ Expr
+    | Pred Expr
+    | If Expr Expr Expr
+      deriving (Eq, Show)
diff --git a/src/K/Eval.hs b/src/K/Eval.hs
new file mode 100644
index 0000000..a7ebcba
--- /dev/null
+++ b/src/K/Eval.hs
@@ -0,0 +1,40 @@
+module K.Eval where
+
+import K.Ast
+import K.Parsing
+import Data.Maybe
+
+isNum Zero = True
+isNum (Succ t) = isNum t
+isNum _ = False
+
+isVal :: Expr -> Bool
+isVal Tru = True
+isVal Fals = True
+isVal t | isNum t = True
+isVal _ = False
+
+eval' x = case x of
+    IsZero Zero               -> Just Tru
+    IsZero (Succ t) | isNum t -> Just Fals
+    IsZero t                  -> IsZero <$> eval' t
+
+    Succ t                    -> Succ <$> eval' t
+
+    Pred Zero                 -> Just Zero
+    Pred (Succ t) | isNum t   -> Just t
+    Pred t                    -> Pred <$> eval' t
+
+    If Tru t _                -> Just t
+    If Fals _ f               -> Just f
+    If c t f                  -> (\c' -> If c' t f) <$> eval' c
+
+    _                         -> Nothing
+
+nf x = fromMaybe x (nf <$> eval' x)
+
+eval :: Expr -> Maybe Expr
+eval t = case nf t of
+    nft | isVal nft -> Just nft
+        | otherwise -> Nothing
+    
diff --git a/src/K/Parsing.hs b/src/K/Parsing.hs
new file mode 100644
index 0000000..32cc526
--- /dev/null
+++ b/src/K/Parsing.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module K.Parsing where
+
+import K.Ast
+import Text.Parsec
+import Control.Monad.Identity
+import qualified Text.Parsec.Token as Token
+import qualified Text.Parsec.Expr as Expr
+
+reservedNames = []
+reservedOps = []
+
+type Parser a = Parsec String () a
+
+langDef :: Token.LanguageDef ()
+langDef = Token.LanguageDef
+  { Token.commentStart    = "{-"
+  , Token.commentEnd      = "-}"
+  , Token.commentLine     = "--"
+  , Token.nestedComments  = True
+  , Token.identStart      = letter
+  , Token.identLetter     = alphaNum <|> oneOf "_'"
+  , Token.opStart         = oneOf ":!#$%&*+./<=>?@\\^|-~"
+  , Token.opLetter        = oneOf ":!#$%&*+./<=>?@\\^|-~"
+  , Token.reservedNames   = reservedNames
+  , Token.reservedOpNames = reservedOps
+  , Token.caseSensitive   = True
+  }
+
+lexer :: Token.TokenParser ()
+lexer = Token.makeTokenParser langDef
+
+parens :: Parser a -> Parser a
+parens = Token.parens lexer
+
+reserved :: String -> Parser ()
+reserved = Token.reserved lexer
+
+semiSep :: Parser a -> Parser [a]
+semiSep = Token.semiSep lexer
+
+reservedOp :: String -> Parser ()
+reservedOp = Token.reservedOp lexer
+
+prefixOp :: String -> (a -> a) -> Expr.Operator String () Identity a
+prefixOp s f = Expr.Prefix (reservedOp s >> return f)
+
+table :: Expr.OperatorTable String () Identity Expr
+table = [
+ [ prefixOp "succ" Succ
+ , prefixOp "pred" Pred
+ , prefixOp "iszero" IsZero
+ ]]
+
+ifthen :: Parser Expr
+ifthen = do
+  reserved "if"
+  cond <- expr
+  reservedOp "then"
+  true <- expr
+  reservedOp "else"
+  false <- expr
+  return (If cond true false)
+
+true, false, zero :: Parser Expr
+true = reserved "true" >> return Tru
+false =reserved "false" >> return Fals
+zero = reserved "0" >> return Zero
+
+factor :: Parser Expr
+factor = foldr1 (<|>) [true, false, zero, ifthen, parens expr]
+
+expr :: Parser Expr
+expr = Expr.buildExpressionParser table factor
+
+contents :: Parser a -> Parser a
+contents p = do
+  Token.whiteSpace lexer
+  r <- p
+  eof
+  return r
+
+parseExpr s = parse (contents expr) "<stdin>" s
diff --git a/src/K/Repl.hs b/src/K/Repl.hs
new file mode 100644
index 0000000..26f21e1
--- /dev/null
+++ b/src/K/Repl.hs
@@ -0,0 +1,22 @@
+module K.Repl where
+
+import Control.Monad.IO.Class
+import K.Parsing
+import K.Eval
+import System.Console.Haskeline
+
+process :: String -> IO ()
+process line = do
+  let res = parseExpr line
+  case res of
+    Left err -> print err
+    Right ex -> print $ eval ex
+
+main :: IO ()
+main = runInputT defaultSettings loop
+  where
+  loop = do
+    minput <- getInputLine "Repl> "
+    case minput of
+      Nothing -> outputStrLn "Goodbye."
+      Just input -> (liftIO $ process input) >> loop