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