1 files changed, 85 insertions, 0 deletions
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