implementation module Sil.Parse

import StdBool
import StdChar
from StdFunc import flip, 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.List
import Data.Maybe
import qualified Text as T
from Text import <+, class Text, instance Text String

import GenEq

import Sil.Error
import Sil.Syntax
import Sil.Types
import Sil.Util.Parser
import Sil.Util.Printer

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

instance toString Token
where
	toString TParenOpen       = "("
	toString TParenClose      = ")"
	toString TBrackOpen       = "["
	toString TBrackClose      = "]"
	toString TBraceOpen       = "{"
	toString TBraceClose      = "}"
	toString TComma           = ","
	toString TColon           = ":"
	toString TSemicolon       = ";"
	toString (TField f)       = "." +++ f
	toString TAssign          = ":="
	toString TTilde           = "~"
	toString TExclamation     = "!"
	toString TPlus            = "+"
	toString TMinus           = "-"
	toString TStar            = "*"
	toString TSlash           = "/"
	toString TPercent         = "%"
	toString TEquals          = "=="
	toString TUnequals        = "<>"
	toString TLe              = "<="
	toString TGe              = ">="
	toString TLt              = "<"
	toString TGt              = ">"
	toString TDoubleBar       = "||"
	toString TDoubleAmpersand = "&&"
	toString (TLit l)         = toString l
	toString TIf              = "if"
	toString TElse            = "else"
	toString TWhile           = "while"
	toString TReturn          = "return"
	toString (TMachineCode s) = "|~ " +++ s
	toString (TName s)        = s
	toString t                = "???"

instance name Token
where
	name (TField _)       = "field"
	name (TLit _)         = "literal"
	name (TName _)        = "name"
	name (TMachineCode _) = "machine code"
	name t                = toString t

tokenise :: [Char] -> MaybeError Error [ParseInput Token]
tokenise cs = reverse <$> tks cs []
where
	tks :: [Char] [ParseInput Token] -> MaybeError Error [ParseInput Token]
	tks [] t = pure t
	tks ['/':'/':r] t = tks (dropWhile ((<>) '\n') r) t
	tks ['/':'*':r] t = tks (skipUntilEndOfComment r) t
	where
		skipUntilEndOfComment []          = []
		skipUntilEndOfComment ['*':'/':r] = r
		skipUntilEndOfComment [_:r]       = skipUntilEndOfComment r
	tks ['.':r=:[c:_]] t | isNameChar c = tks r` [PI_Token $ TField $ toString f:t]
	where (f,r`) = span isNameChar r
	tks [':':'=':r] t = tks r [PI_Token TAssign         :t]
	tks ['=':'=':r] t = tks r [PI_Token TEquals         :t]
	tks ['<':'>':r] t = tks r [PI_Token TUnequals       :t]
	tks ['<':'=':r] t = tks r [PI_Token TLe             :t]
	tks ['>':'=':r] t = tks r [PI_Token TGe             :t]
	tks ['<'    :r] t = tks r [PI_Token TLt             :t]
	tks ['>'    :r] t = tks r [PI_Token TGt             :t]
	tks ['|':'|':r] t = tks r [PI_Token TDoubleBar      :t]
	tks ['&':'&':r] t = tks r [PI_Token TDoubleAmpersand:t]
	tks ['('    :r] t = tks r [PI_Token TParenOpen      :t]
	tks [')'    :r] t = tks r [PI_Token TParenClose     :t]
	tks ['['    :r] t = tks r [PI_Token TBrackOpen      :t]
	tks [']'    :r] t = tks r [PI_Token TBrackClose     :t]
	tks ['{'    :r] t = tks r [PI_Token TBraceOpen      :t]
	tks ['}'    :r] t = tks r [PI_Token TBraceClose     :t]
	tks [','    :r] t = tks r [PI_Token TComma          :t]
	tks [':'    :r] t = tks r [PI_Token TColon          :t]
	tks [';'    :r] t = tks r [PI_Token TSemicolon      :t]
	tks ['!'    :r] t = tks r [PI_Token TExclamation    :t]
	tks ['~'    :r] t = tks r [PI_Token TTilde          :t]
	tks ['+'    :r] t = tks r [PI_Token TPlus           :t]
	tks ['-'    :r] t = tks r [PI_Token TMinus          :t]
	tks ['*'    :r] t = tks r [PI_Token TStar           :t]
	tks ['/'    :r] t = tks r [PI_Token TSlash          :t]
	tks ['%'    :r] t = tks r [PI_Token TPercent        :t]
	tks ['i':'f'                :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TIf    :t]
	tks ['e':'l':'s':'e'        :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TElse  :t]
	tks ['w':'h':'i':'l':'e'    :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TWhile :t]
	tks ['r':'e':'t':'u':'r':'n':r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TReturn:t]
	tks ['T':'r':'u':'e'        :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token $ TLit $ BLit True :t]
	tks ['F':'a':'l':'s':'e'    :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token $ TLit $ BLit False:t]
	tks ['|':'~':r] t = tks r` [PI_Token $ TMachineCode $ toString c:t]
	where (c,r`) = span (not o flip isMember ['\r\n']) r
	tks cs=:[h:r] t
	| h == '\n'          = tks r [PI_NewLine:t]
	| isSpace h          = tks (dropWhile isSpace cs) t
	| isDigit h          = tks numrest [PI_Token $ TLit $ ILit $ toInt $ toString num:t]
	| not (isNameChar h) = Error $ P_Invalid "name" h
	| otherwise          = tks namerest [PI_Token $ TName $ toString name:t]
	where
		(name,namerest) = span isNameChar cs
		(num,numrest)   = span isDigit cs

	isNameChar :: Char -> Bool
	isNameChar c = isAlphanum c || isMember c ['_\'']

	isNotNameChar = not o isNameChar

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

program :: Parser Token Program
program =
	many initialisation >>= \globss ->
	some function >>= \fs ->
	eof $>
	{p_globals=flatten globss, p_funs=fs}

function :: Parser Token (Positioned Function)
function =
	type >>= \t ->
	getPositioner >>= \pos ->
	name >>= \n ->
	parenthised (seplist TComma arg) >>= \args ->
	braced codeblock >>= \cb ->
	pure $ pos
		{ f_type = t
		, f_name = n
		, f_args = args
		, f_code = cb
		}

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

initialisation :: Parser Token [Positioned Initialisation]
initialisation = type >>= \t -> seplist TComma (init t) <* item TSemicolon
where
	init t =
		getPositioner >>= \pos ->
		name >>= \n ->
		optional (item TAssign *> expression) >>= \v ->
		pure $ pos $ {init_type=t, init_name=n, init_value=v}

statement :: Parser Token (Positioned Statement)
statement =
	getPositioner >>= \pos ->
	(   declaration
	<|> liftM Application (expression <* item TSemicolon)
	<|> return
	<|> if`
	<|> while
	<|> machinecode
	) >>= pure o pos
where
	declaration :: Parser Token Statement
	declaration = liftM2 Declaration name (item TAssign *> expression <* item TSemicolon)

	return :: Parser Token Statement
	return = liftM Return (item TReturn *> optional expression <* item TSemicolon)

	machinecode :: Parser Token Statement
	machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
	where isMachineCode (TMachineCode _) = True; isMachineCode _ = False

	if` :: Parser Token Statement
	if` = item TIf *>
		parenthised expression >>= \cond ->
		braced codeblock >>= \iftrue ->
		many elseif >>= \elseifs ->
		optional (item TElse *> braced codeblock) >>= \iffalse ->
		pure $ If [(cond,iftrue):elseifs] iffalse
	where
		elseif = list [TElse, TIf] *>
			parenthised expression >>= \cond ->
			braced codeblock >>= \block ->
			pure (cond, block)

	while :: Parser Token Statement
	while = item TWhile *>
		parenthised expression >>= \cond ->
		braced codeblock >>= \do ->
		pure $ While cond do

expression :: Parser Token Expression
expression
	= rightAssoc (op TDoubleBar       LogOr)
	$ rightAssoc (op TDoubleAmpersand LogAnd)
	$ rightAssoc (op TEquals          Equals
	          <|> op TUnequals        Unequals
	          <|> op TLe              CmpLe
	          <|> op TGe              CmpGe
	          <|> op TLt              CmpLt
	          <|> op TGt              CmpGt)
	$ rightAssoc (op TColon           Cons)
	$ leftAssoc  (op TPlus            Add
	          <|> op TMinus           Sub)
	$ leftAssoc  (op TStar            Mul
	          <|> op TSlash           Div)
	$ leftAssoc  (op TPercent         Rem)
	$ noInfix
where
	op :: Token Op2 -> Parser Token Op2
	op token operator = item token $> operator

	rightAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
	rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
		>>= pure o maybe e1 (\(op,e2) -> BuiltinApp2 e1 op e2)

	leftAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
	leftAssoc opp appp = appp >>= \e1 -> many (opp >>= \op -> appp >>= \e -> pure (op,e))
		>>= foldM (\e (op,e2) -> pure $ BuiltinApp2 e op e2) e1

	noInfix :: Parser Token Expression
	noInfix
		=   liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
		<|> op TTilde       Neg
		<|> op TExclamation Not
		<|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field)
	where
		op :: Token Op1 -> Parser Token Expression
		op token operator = liftM (BuiltinApp operator) (item token *> noInfix)

		field :: Parser Token Name
		field = satisfy (\t -> t =: TField _) >>= \(TField f) -> pure f

	simpleExpr :: Parser Token Expression
	simpleExpr = liftM Literal literal
		<|> liftM Name name
		<|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
		<|> flip List [] o pure <$> bracked type
		<|> List Nothing <$> bracked (seplist TComma expression)
		<|> parenthised expression

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

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

type :: Parser Token Type
type
	=   simpletype "Bool" TBool
	<|> simpletype "Int"  TInt
	<|> simpletype "Void" TVoid
	<|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
	<|> TList <$> bracked type
	<?> P_Expected "type"
where
	simpletype s t = item (TName s) $> t

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

parenthised :: (Parser Token a) -> Parser Token a
parenthised p = item TParenOpen *> p <* item TParenClose

bracked :: (Parser Token a) -> Parser Token a
bracked p = item TBrackOpen *> p <* item TBrackClose

braced :: (Parser Token a) -> Parser Token a
braced p = item TBraceOpen *> p <* item TBraceClose

min2seplist :: a (Parser a b) -> Parser a [b] | ==, name a
min2seplist sep val =
	val >>= \v1 ->
	item sep *>
	seplist sep val >>= \vs ->
	pure [v1:vs]