implementation module SaplParser

import StdEnv, Map, Void, Error
import SaplTokenizer, SaplStruct, FastString

(>>=) infixl 1
(>>=) f g = \st0 ->
		case f st0 of
			Ok (r, st1) = g r st1
			Error str		 = Error str

(>>|) infixl 1
(>>|) f g = f >>= \_ -> g

returnS r :== \s -> Ok (r,s)
returnE e :== \s -> Error e

mandatory errmsg (Just t, ts)
		= returnS (t, ts)
mandatory errmsg (Nothing, ts)
		= returnE (ts, errmsg)

incLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level + 1})
decLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level - 1})
getLevel :== \s -> Ok (s.ps_level, s)
addFunction name args :== \s -> Ok (name, {s & ps_functions = put (unpackVar name) args s.ps_functions})
addCAF name :== \s -> Ok (name, {s & ps_CAFs = put (unpackVar name) Void s.ps_CAFs})
defaultState = {ps_level = 0, ps_constructors = newMap, ps_functions = newMap, ps_CAFs = newMap, ps_genFuns = []}

addConstructor name def :== \s -> Ok (name, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
checkConstructor name :== \s -> Ok (isJust (get name s.ps_constructors), s)
addGenFun fun :== \s -> Ok (fun, {s & ps_genFuns = [fun:s.ps_genFuns]})

addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
	nr_cons = length conses
	adddef m (SaplConstructor name idx as) 
		= put (unpackVar name) {index = idx, nr_cons = nr_cons, nr_args = length as, args = as} m

// Add Tuple constructor if necessary
addTupleCons name | startsWith "_Tuple" name && size name > 6 =
		checkConstructor name
	>>= \b = if b (returnS Void) (addConstructor (NormalVar name 0) newdef >>| addGenFun newadt >>| returnS Void)
where
	(newadt, newdef) = gendefs name

	gendefs name
		# idxpart = name % (6, size name)
		# (l,r) = case charIndex idxpart 1 '!' of
			(True, idx) = (toInt (idxpart % (0,idx-1)), toInt (idxpart % (idx+1,size idxpart)))
			(False, _)  = (toInt idxpart, 0)
		= (genadt l r, genrec l r)

	genrec nrargs s = {index = 0, nr_cons = 1, nr_args = nrargs, args = [genarg i s \\ i <- [1..nrargs]]}
	genadt nrargs s = FTADT (NormalVar name 0) [SaplConstructor (NormalVar name 0) 0 [genarg i s \\ i <- [1..nrargs]]]
	
	genarg i s | s bitand (1 << (i-1)) > 0
		= StrictVar "_" 0
		= NormalVar "_" 0		

addTupleCons _ = returnS Void

factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
factor [TOpenParenthesis:ts] = 
				application ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (Just t, tl ts)
										  = returnE (ts, "Missing close parenthesis")
factor ts = returnS (Nothing, ts)

application [TOpenParenthesis:ts] = 
				application ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (t, tl ts)
										  = returnE (ts, "Missing close parenthesis")

application [TIdentifier name:ts] = 
				getLevel
			>>= \level = returnS (NormalVar name level)
			>>= \t = addTupleCons name
			>>= \_ = args_factor ts
			>>= \(as, ts) = case as of
								[] = returnS (SVar t, ts) // !!!
								   = returnS (SApplication t as, ts)

application [TLit lit:ts] = returnS (SLit lit, ts)
application ts = returnE (ts, "Invalid application")

selectexpr [TIfKeyword:ts] = 
				arg_adv ts 
			>>= mandatory "Missing predicate"
			>>= \(pred, ts) = arg_adv ts
			>>= mandatory "Missing left hand side"
			>>= \(lhs, ts) = arg_adv ts
			>>= mandatory "Missing right hand side"			
			>>= \(rhs, ts) = returnS (Just (SIf pred lhs rhs), ts)
				
selectexpr [TSelectKeyword:ts] = 
				arg_adv ts
			>>= mandatory "Missing select expression"				
			>>= \(expr, ts) = args_pattern ts
			>>= \(ps, ts) = if (isEmpty ps) 
							   (returnE (ts, "Missing select patterns"))
							   (returnS (Just (SSelect expr ps), ts))
			
selectexpr ts = returnS (Nothing, ts)

mainexpr ts = selectexpr ts 
			>>= \(t, ts) = case t of
								Just t = returnS (t, ts)
						   			   = application ts

letdefinitions ts = letdef_1 ts []
where
	letdef_1 [TIdentifier name, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = application ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (NormalVar name level) t:as]
	letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = application ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (StrictVar name level) t:as]
	letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
	letdef_2 [TColon: ts] as = letdef_1 ts as
	letdef_2 ts as = returnS (reverse as, ts)

body [TLetKeyword:ts] =
				incLevel ts
			>>= \ts = letdefinitions ts
			>>= \(ds, ts) = case hd ts of
					TInKeyword = returnS (tl ts)
							   = returnE (ts, "Missing \"in\" keyword")
			>>= \ts = mainexpr ts
			>>= \(t, ts) = returnS (SLet t ds, ts)
			>>= decLevel
	
body [TOpenBracket:ts] = skip ts	// ABC code: skip it	
where
	skip [TCloseBracket:ts] = returnS (SAbortBody, ts)
	skip [] = returnE ([], "Missing close bracket in ABC code definition")
	skip [t:ts] = skip ts
			
body ts = mainexpr ts

args_factor ts = args_ factor ts
args_pattern ts = args_ arg_pattern ts

args_ f ts = args` ts []
where
	args` ts as = f ts 
				>>= \(t, ts) = case t of
						Just r = args` ts [r:as]
							   = returnS (reverse as, ts)

arg_pattern [TOpenParenthesis:TLit lit:ts] =
			case hd ts of
				TSelectAssignmentOp = body (tl ts)
							  = returnE (ts, "Missing select assignment operator")
		>>=	\(t, ts) = case hd ts of
				TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
							  = returnE (ts, "Missing close parenthesis")

arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
			incLevel ts
		>>= \ts = addTupleCons cons
		>>= \_ = args ts
		>>= \(as, ts) = case hd ts of
				TSelectAssignmentOp = body (tl ts)
							  = returnE (ts, "Missing select assignment operator")
		>>=	\(t, ts) = case hd ts of
				TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
							  = returnE (ts, "Missing close parenthesis")
		>>= decLevel
where
	mbCons as = if (cons=="_") PDefault (PCons cons as)

arg_pattern ts = returnS (Nothing, ts)

arg_adv [TOpenParenthesis:ts] = 
				body ts >>= \(t, ts) = returnS (Just t, ts)
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (t, tl ts)
										  = returnE (ts, "Missing close parenthesis")
		
arg_adv ts = factor ts

args ts = args_ ts []
where
	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as] 
	args_ ts as = returnS (reverse as, ts)

args_annotated ts = args_ ts []
where
	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as] 
	args_ [TStrictIdentifier name:ts] as = args_ ts [StrictVar name 0:as]
	args_ ts as = returnS (reverse as, ts)

args_record ts = args_1 ts []
where
	args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [NormalVar name level:as]
	args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [StrictVar name level:as]		
	args_1 ts as = returnE (ts, "Missing argument")
	args_2 [TColon:ts] as = args_1 ts as
	args_2 ts as = returnS (reverse as, ts)

args_adt ts = args_1 ts [] 0
where
	args_1 [TIdentifier name:ts] cs i = 
			getLevel 
		>>= \level = args_annotated ts 
		>>= \(ss,ts) = args_2 ts [SaplConstructor (NormalVar name level) i ss:cs] i
		
	args_1 ts cs _ = returnE (ts, "Missing argument")
	args_2 [TVerticalBar:ts] cs i = args_1 ts cs (i+1)
	args_2 ts cs _ = returnS (reverse cs, ts)

// record
constr [TTypeDef, TIdentifier name, TAssignmentOp, TOpenBracket: ts] =
				getLevel
			>>= \level = args_record ts
			>>= \(as, ts) = case hd ts of
						TCloseBracket = addConstructor (NormalVar name level) {index = 0, nr_cons = 1, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
									  = returnE (ts, "Missing close parenthesis3")

// ADT
constr [TTypeDef, TIdentifier name, TAssignmentOp: ts] =
				getLevel
			>>= \level = args_adt ts 
			>>= \(as, ts) = addConstructors as
			>>= \_ = returnS (FTADT (NormalVar name level) as, ts)

constr [TTypeDef:ts] = returnE (ts, "Invalid type definition")
constr ts = returnE (ts, "Not a type definition")

func [TIdentifier name, TCAFAssignmentOp:ts] = 
				getLevel
			>>= \level = body ts
			>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF tname t, ts)
			
func [TIdentifier name:ts] = 
				getLevel
			>>= \level = args_annotated ts 
			>>= \(as, ts) = case hd ts of
					TAssignmentOp	   = returnS (True, tl ts)
					TMacroAssignmentOp = returnS (False, tl ts)					
									   = returnE (ts, "Missing assignment operator")
			>>= \(func, ts) = body ts 
			>>= \(t, ts) = if func 
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc tname t as, ts))
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro tname t as, ts))

func ts=:[TTypeDef:_] = constr ts >>= \(f,ts) = returnS (f, ts)
func ts = returnE (ts, "Not a function or type definition")

skip_newlines [TEndOfLine:ts] = skip_newlines ts
skip_newlines ts = returnS ts

program ts fs =
			skip_newlines ts
		>>= \ts = func ts
		>>= \(f, ts) = skip_newlines ts
		>>= \ts = if (length ts == 0) (returnS ([f:fs], ts)) (program ts [f:fs])
		
parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts 
	# ts = map (\(PosToken _ _ t) = t) pts
	= case (program ts []) defaultState of
				Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps)
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
where
	findpos rest_ts 
		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
		= case hd rest_pts of
			PosToken lp cp _ = (lp, cp)
		
parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm,ParserState)		
parseExpr pts 
	# ts = map (\(PosToken _ _ t) = t) pts
	= case (body ts) defaultState of
				Ok ((fts, _),ps) = Ok (fts,ps)
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
where
	findpos rest_ts 
		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
		= case hd rest_pts of
			PosToken lp cp _ = (lp, cp)
		
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
mergeParserStates pst1 (Just pst2)
	= {pst1 &
	   ps_constructors = mergeMaps pst2.ps_constructors pst1.ps_constructors,
	   ps_functions    = mergeMaps pst2.ps_functions    pst1.ps_functions,
	   ps_CAFs         = mergeMaps pst2.ps_CAFs         pst1.ps_CAFs,
	   ps_genFuns	   = []}
where
	mergeMaps m1 m2 = putList (toList m2) m1

mergeParserStates pst1 Nothing = pst1