-- vim: et ts=2 sw=2 ai:
{-# LANGUAGE LambdaCase #-}
module SPL.Parse (parse)
where

import Control.Applicative
import Control.Monad
import Data.Functor

import Text.Parsec (sepBy, (<?>))
import qualified Text.Parsec as P

import SPL.Syntax hiding (TInt,TBool,TChar,TArrow)
import qualified SPL.Syntax
import SPL.Lex

type Parser t = P.Parsec [Token] () t

satisfy :: (Token -> Bool) -> Parser Token
satisfy p = P.tokenPrim
  show
  (const . const)
  (\t -> if p t then Just t else Nothing)

token :: Token -> Parser Token
token t = satisfy (== t) <?> show t

check :: (Token -> Maybe a) -> Parser a
check f = P.tokenPrim
  show
  (const . const)
  f

parse :: [Token] -> Either P.ParseError Program
parse = P.parse spl "Not a valid program" . filter (not . isCommentToken)

spl :: Parser Program
spl = collect <$> (many toplevel <* P.eof)
  where
    collect :: [Either Variable Function] -> Program
    collect vfs = Program [f | Right f <- vfs] [v | Left v <- vfs]

toplevel :: Parser (Either Variable Function)
toplevel = Left <$> var <|> Right <$> fun

comment :: Parser String
comment = toString <$> satisfy isCommentToken
  where
    toString (TSingleComment s) = s
    toString (TBlockComment s)  = s

parenthesised :: Parser a -> Parser a
parenthesised p = token TParenOpen *> p <* token TParenClose

braced :: Parser a -> Parser a
braced p = token TBraceOpen *> p <* token TBraceClose

var :: Parser Variable
var = do
  t  <- Just <$> plainType <|> (token TVar $> Nothing)
  id <- ident
  token TEquals
  val <- expr
  token TSemicolon
  return $ Variable id t val

fun :: Parser Function
fun = do
  id <- ident
  args <- parenthesised $ ident `sepBy` token TComma
  ftype <- optional (token TColonColon *> funType)
  token TBraceOpen
  vars <- many var
  stmt <- statements
  token TBraceClose
  return $ Function id ftype args vars stmt

ident :: Parser Name
ident = (\(TIdent id) -> id) <$> satisfy isIdentToken

funType :: Parser Type
funType = do
  argtypes <- many plainType
  token TArrow
  rettype <- plainType
  return $ SPL.Syntax.TArrow argtypes rettype

plainType :: Parser Type
plainType = -- TODO
  token TIntType  $> SPL.Syntax.TInt  <|>
  token TBoolType $> SPL.Syntax.TBool <|>
  token TCharType $> SPL.Syntax.TChar

expr :: Parser Expression
expr = literal -- TODO
  where
    literal :: Parser Expression
    literal = fmap Literal $ check $ \case
      TInt i  -> Just (LInt i)
      TBool b -> Just (LBool b)
      _       -> Nothing

statements :: Parser Statement
statements = foldr1 Seq <$> some statement <|> pure Nop

statement :: Parser Statement
statement =
  liftM3 If
    (token TIf *> parenthesised expr)
    (braced statements)
    (optional (token TElse *> braced statements)) <|>
  liftM2 While
    (token TWhile *> parenthesised expr)
    (braced statements) <|>
  liftM2 Assign
    ident
    (token TEquals *> expr <* token TSemicolon) <|>
  Eval <$> (expr <* token TSemicolon) <|>
  Return <$> (token TReturn *> optional expr <* token TSemicolon)