SaplParser.icl

implementation module Sapl.SaplParser

import StdEnv, Data.Error
import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString

from Data.Map import :: Map
import qualified Data.Map as DM

(>>=) 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 = 'DM'.put (unpackVar name) args s.ps_functions})
addCAF name :== \s -> Ok (name, {s & ps_CAFs = 'DM'.put (unpackVar name) () s.ps_CAFs})
defaultState = {ps_level = 0, ps_constructors = 'DM'.newMap, ps_functions = 'DM'.newMap, ps_CAFs = 'DM'.newMap, ps_genFuns = []}

addConstructor name def :== \s -> Ok (name, {s & ps_constructors = 'DM'.put (unpackVar name) def s.ps_constructors})
checkConstructor name :== \s -> Ok (isJust ('DM'.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) 
		= 'DM'.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 ()) (addConstructor (NormalVar name 0) newdef >>| addGenFun newadt >>| returnS ())
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
		= TypedVar (StrictVar "_" 0) NoType
		= TypedVar (NormalVar "_" 0) NoType	

addTupleCons _ = returnS ()

read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
read_int ts = returnS (Nothing, ts)

type [TTypeDef, TIdentifier type:ts] = returnS (Type type, ts)
type ts = returnS (NoType, ts) 

expr [TOpenParenthesis:ts] = 
				mexpr ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (Just t, tl ts)
										  = returnE (ts, "Missing close parenthesisx")

expr [TLit lit:ts] = returnS (Just (SLit lit), ts)

expr [TIdentifier name:ts] = 
				getLevel
			>>= \level = returnS (NormalVar name level)
			>>= \t = addTupleCons name
			>>= \_ = args_expr ts
			>>= \(as, ts) = case as of
								[] = returnS (Just (SVar t), ts)
								   = returnS (Just (SApplication (SVar t) as), ts)

expr [TSelectKeyword:ts] = 
				sexpr ts 
			>>= mandatory "Missing select expression"
			>>= \(expr, ts) = type ts			
			>>= \(ty, ts) = read_int ts			
			>>= mandatory "Missing select index"
			>>= \(idx, ts) = args_expr ts
			>>= \(as, ts) = case as of
								[] = returnS (Just (SSelect expr ty idx), ts)
								   = returnS (Just (SApplication (SSelect expr ty idx) as), ts)

expr [TUpdateKeyword:ts] = 
				sexpr ts 
			>>= mandatory "Missing update expression"
			>>= \(expr, ts) = type ts
			>>= \(ty, ts) = upd_list ts
			>>= \(upds, ts) = returnS (Just (SUpdate expr ty upds), ts)
where
	upd_list [TOpenSquareBracket:ts] = 
				update_1 ts []
			>>=	\(us, ts) = case hd ts of
						TCloseSquareBracket = returnS (us, tl ts)
								      = returnE (ts, "Missing close square bracket")
	upd_list ts = returnE (ts, "Missing open bracket")

	update_1 [TLit (LInt idx),TColon:ts] as =
			 	expr ts
		 	>>= mandatory "Missing field update expression"
		 	>>= \(expr, ts) = update_2 ts [(idx, expr):as]
	update_1 ts as = returnE (ts, "Invalid field \"update\"")
	update_2 [TComma: ts] as = update_1 ts as
	update_2 ts as = returnS (reverse as, ts)	

expr ts = returnS (Nothing, ts)

sexpr [TOpenParenthesis:ts] = 
				mexpr ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (Just t, tl ts)
										  = returnE (ts, "Missing close parenthesisx")

sexpr [TLit lit:ts] = returnS (Just (SLit lit), ts)

sexpr [TIdentifier name:ts] = 
				getLevel
			>>= \level = returnS (NormalVar name level)
			>>= \t = addTupleCons name
			>>= \_ = returnS (Just (SVar t), ts)

sexpr ts = returnS (Nothing, ts)

mexpr ts = expr ts >>= mandatory "Missing expression"

letdefinitions ts = letdef_1 ts []
where
	letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = body False ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
	letdef_1 [TIdentifier name, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = body False ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
	letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = body False ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]			
	letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as = 
				getLevel
			>>= \level = body False ts 
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
	letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
	letdef_2 [TComma: ts] as = letdef_1 ts as
	letdef_2 ts as = returnS (reverse as, ts)

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

body simple [TLetKeyword:ts] =
				incLevel ts
			>>= \ts = letdefinitions ts
			>>= \(ds, ts) = case hd ts of
					TInKeyword = returnS (tl ts)
							   = returnE (ts, "Missing \"in\" keyword")
			>>= \ts = body False ts
			>>= \(t, ts) = returnS (SLet t ds, ts)
			>>= decLevel

body simple [TCaseKeyword:ts] = 
				body True ts		
			>>= \(expr, ts) = args_pattern ts
			>>= \(ps, ts) = if (isEmpty ps) 
							   (returnE (ts, "Missing case patterns"))
							   (returnS (SCase expr ps, ts))
	
body simple [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 simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"

args_expr ts = args_ sexpr 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
				TCaseAssignmentOp = body False (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 parenthesis3")

arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
			incLevel ts
		>>= \ts = addTupleCons cons
		>>= \_ = args ts
		>>= \(as, ts) = case hd ts of
				TCaseAssignmentOp = body False (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 parenthesis4")
		>>= decLevel
where
	mbCons as = if (cons=="_") PDefault (PCons cons as)

arg_pattern ts = returnS (Nothing, 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,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) (Type type):as]
	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) NoType:as] 
	args_ [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = args_ ts [TypedVar (StrictVar name 0) (Type type):as]
	args_ [TStrictIdentifier name:ts] as = args_ ts [TypedVar (StrictVar name 0) NoType:as]
	args_ ts as = returnS (reverse as, ts)

args_record ts = args_1 ts []
where
	args_1 [TIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) (Type type):as]
	args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) NoType:as]
	args_1 [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) (Type type):as]	
	args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) NoType:as]	
	args_1 ts as = returnE (ts, "Missing argument")
	args_2 [TComma: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, TTypeDef, TIdentifier type, TCAFAssignmentOp:ts] = typed_caf name (Type type) ts			
func [TIdentifier name, TCAFAssignmentOp:ts] = typed_caf name NoType ts
func [TIdentifier name, TTypeDef, TIdentifier type:ts] = typed_fun name (Type type) ts			
func [TIdentifier name:ts] = typed_fun name NoType ts

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

typed_caf name type ts =
				getLevel
			>>= \level = body False ts
			>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)

typed_fun name type 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 False ts 
			>>= \(t, ts) = if func 
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))

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 character "+++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 False 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 character "+++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 = 'DM'.putList ('DM'.toList m2) m1

mergeParserStates pst1 Nothing = pst1