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

import Text.Parsec (sepBy)
import qualified Text.Parsec

import Control.Applicative
import Data.Functor

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

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

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

token :: Token -> Parser Token
token = satisfy . (==)

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

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

spl :: Parser Program
spl = collect <$> (many toplevel <* Text.Parsec.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

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
  token TParenOpen
  args <- ident `sepBy` token TComma
  token TParenClose
  ftype <- optional (token TColonColon *> funType)
  token TBraceOpen
  vars <- many var
  stmt <- statement
  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

statement :: Parser Statement
statement = fail "" -- TODO