{-# 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