implementation module Sil.Parse

import StdBool
import StdChar
from StdFunc import o
import StdInt
import StdList
import StdString
import StdTuple

import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.Maybe
from Text import <+

import GenEq

import Sil.Parse.Parser
import Sil.Syntax
import Sil.Util

derive gEq Token, Literal
instance == Token where == a b = gEq{|*|} a b

instance toString Token
where
	toString TParenOpen  = "("
	toString TParenClose = ")"
	toString TBraceOpen  = "{"
	toString TBraceClose = "}"
	toString TComma      = ","
	toString TSemicolon  = ";"
	toString TAssign     = ":="
	toString (TLit l)    = toString l
	toString TIf         = "if"
	toString TWhile      = "while"
	toString TReturn     = "return"
	toString (TName s)   = s

instance name Token
where
	name (TLit _)  = "literal"
	name (TName _) = "name"
	name t         = toString t

instance toString ParseError
where
	toString (Invalid loc sym)       = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
	toString (Expected s)            = "Expected " <+ s <+ "."
	toString UnknownError            = "Unknown error."

tokenise :: [Char] -> MaybeError ParseError [Token]
tokenise cs = reverse <$> tks cs []
where
	tks :: [Char] [Token] -> MaybeError ParseError [Token]
	tks [] t = pure t
	tks ['(':r] t = tks r [TParenOpen :t]
	tks [')':r] t = tks r [TParenClose:t]
	tks ['{':r] t = tks r [TBraceOpen :t]
	tks ['}':r] t = tks r [TBraceClose:t]
	tks [',':r] t = tks r [TComma     :t]
	tks [';':r] t = tks r [TSemicolon :t]
	tks [':':'=':r] t = tks r [TAssign    :t]
	tks ['i':'f'                :s:r] t | isSpace s = tks r [TIf    :t]
	tks ['w':'h':'i':'l':'e'    :s:r] t | isSpace s = tks r [TWhile :t]
	tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
	tks ['T':'r':'u':'e'        :s:r] t | isSpace s = tks r [TLit $ BLit True:t]
	tks ['F':'a':'l':'s':'e'    :s:r] t | isSpace s = tks r [TLit $ BLit False:t]
	tks cs=:[h:_] t
	| isSpace h          = tks (dropWhile isSpace cs) t
	| isDigit h          = tks numrest [TLit $ ILit $ toInt $ toString num:t]
	| not (isNameChar h) = Error $ Invalid "name" h
	| otherwise          = tks namerest [TName $ toString name:t]
	where
		(name,namerest) = span isNameChar cs
		(num,numrest)   = span isDigit cs

	isNameChar :: (Char -> Bool)
	isNameChar = isAlpha

parse :: ([Token] -> MaybeError ParseError Program)
parse = fst o runParser program

program :: Parser Token Program
program = (\fs -> {p_funs=fs}) <$> some function <* eof

function :: Parser Token Function
function =
	type >>= \t ->
	name >>= \n ->
	item TParenOpen >>= \_ ->
	seplist TComma arg >>= \args ->
	item TParenClose >>= \_ ->
	item TBraceOpen >>= \_ ->
	codeblock >>= \cb ->
	item TBraceClose >>= \_ -> pure
		{ f_type = t
		, f_name = n
		, f_args = args
		, f_code = cb
		}

codeblock :: Parser Token CodeBlock
codeblock = many initialisation >>= \i ->
	many statement >>= \s ->
	pure {cb_init=i, cb_content=s}

initialisation :: Parser Token Initialisation
initialisation =
	type >>= \t ->
	name >>= \n ->
	item TSemicolon >>= \_ ->
	pure {init_type=t, init_name=n}

statement :: Parser Token Statement
statement = (declaration
	<|> liftM Application application
	<|> return
/*	<|> if`
	<|> while*/) <* item TSemicolon
where
	declaration :: Parser Token Statement
	declaration = liftM2 Declaration name (item TAssign *> application)

	application :: Parser Token Application
	application
		=   liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
		<|> liftM Literal literal
		<|> liftM Name name

	return :: Parser Token Statement
	return = liftM Return (item TReturn *> optional application)

name :: Parser Token Name
name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
where
	isName (TName _) = True
	isName _         = False

arg :: Parser Token Arg
arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
	<?> Expected "argument"

type :: Parser Token Type
type
	=   type "Bool" TBool
	<|> type "Int"  TInt
	<|> type "Void" TVoid
	<?> Expected "type"
where
	type s t = item (TName s) *> pure t

literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
where
	isLit :: Token -> Bool
	isLit (TLit _) = True
	isLit _        = False