diff options
Diffstat (limited to 'frontend/parse.icl')
| -rw-r--r-- | frontend/parse.icl | 2811 |
1 files changed, 2811 insertions, 0 deletions
diff --git a/frontend/parse.icl b/frontend/parse.icl new file mode 100644 index 0000000..78c3780 --- /dev/null +++ b/frontend/parse.icl @@ -0,0 +1,2811 @@ +implementation module parse + +import StdEnv +import scanner, syntax, hashtable, utilities, predef + +// RWS ... +ParseOnly :== False +import RWSDebug + +// +++ move to utilities? + +groupBy :: (a a -> Bool) [a] -> [[a]] +groupBy eq [] + = [] +groupBy eq [h : t] + = [[h : this] : groupBy eq other] + where + (this, other) + = span (eq h) t +/* +ident = { id_name = "id name", id_info = nilPtr } +Start + = is_record_update [{nu_selectors=[PS_Record ident No],nu_update_expr=PE_Empty}] + +is_record_update :: [NestedUpdate] -> Bool +is_record_update [{nu_selectors=[(PS_Record _ _) : _]}] + = True ->> "is_record_update" +is_record_update updates + = False ->> ("not is_record_update", updates) +*/ + +// ... RWS + +/* + +Parser for Clean 2.0 + +Conventions: + +- Parsing funtions with a name of the form try.. can fail without generating an error. + The parser will try an other alternative. +- Parsing functions with a name of the form want.. should succeed. If these functions + fail an error message is generated. +- Functions with names containing the character '_' are local functions. +- All functions should consume the tokens taken form the state or given as argument, + or put these tokens back themselves. + +*/ + +:: *ParseErrorAdmin = + { pea_file :: !*File + , pea_ok :: !Bool + } + +:: *ParseState = + { ps_scanState :: !ScanState + , ps_error :: !*ParseErrorAdmin + , ps_skipping :: !Bool + , ps_hash_table :: !*HashTable + , ps_pre_def_symbols :: !*PredefinedSymbols + } + +appScanState :: (ScanState -> ScanState) !ParseState -> ParseState +appScanState f pState=:{ps_scanState} + # ps_scanState = f ps_scanState + = { pState & ps_scanState = ps_scanState } + +accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState) +accScanState f pState=:{ps_scanState} + # ( x, ps_scanState) = f ps_scanState + = ( x, {pState & ps_scanState = ps_scanState }) + +makeStringTypeSymbol pState=:{ps_pre_def_symbols} + #! string_id = ps_pre_def_symbols.[PD_StringType] + = (MakeNewTypeSymbIdent string_id.pds_ident 0, pState) + +makeListTypeSymbol arity pState=:{ps_pre_def_symbols} + #! list_id = ps_pre_def_symbols.[PD_ListType] + = (MakeNewTypeSymbIdent list_id.pds_ident arity, pState) + +makeLazyArraySymbol arity pState=:{ps_pre_def_symbols} + #! lazy_array_id = ps_pre_def_symbols.[PD_LazyArrayType] + = (MakeNewTypeSymbIdent lazy_array_id.pds_ident arity, pState) + +makeStrictArraySymbol arity pState=:{ps_pre_def_symbols} + #! strict_array_id = ps_pre_def_symbols.[PD_StrictArrayType] + = (MakeNewTypeSymbIdent strict_array_id.pds_ident arity, pState) + +makeUnboxedArraySymbol arity pState=:{ps_pre_def_symbols} + #! unboxed_array_id = ps_pre_def_symbols.[PD_UnboxedArrayType] + = (MakeNewTypeSymbIdent unboxed_array_id.pds_ident arity, pState) + +makeTupleTypeSymbol form_arity act_arity pState=:{ps_pre_def_symbols} + #! tuple_id = ps_pre_def_symbols.[GetTupleTypeIndex form_arity] + = (MakeNewTypeSymbIdent tuple_id.pds_ident act_arity, pState) + +makeNilExpression pState=:{ps_pre_def_symbols} + #! nil_id = ps_pre_def_symbols.[PD_NilSymbol] + = (PE_List [PE_Ident nil_id.pds_ident], pState) + +makeConsExpression a1 a2 pState=:{ps_pre_def_symbols} + #! cons_id = ps_pre_def_symbols.[PD_ConsSymbol] + = (PE_List [PE_Ident cons_id.pds_ident, a1, a2], pState) + +class try a :: !Token !*ParseState -> (!Optional a, !*ParseState) +class want a :: !*ParseState -> (!a, !*ParseState) + +stringToIdent :: !String !IdentClass !*ParseState -> (!Ident, !*ParseState) +stringToIdent ident ident_class pState=:{ps_hash_table} + # (ident, ps_hash_table) = putIdentInHashTable ident ident_class ps_hash_table + = (ident, { pState & ps_hash_table = ps_hash_table } ) + +internalIdent :: !String !*ParseState -> (!Ident, !*ParseState) +internalIdent prefix pState + # ({fp_line,fp_col},pState=:{ps_hash_table}) = getPosition pState + case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col + (case_ident, ps_hash_table) = putIdentInHashTable case_string IC_Expression ps_hash_table + = (case_ident, { pState & ps_hash_table = ps_hash_table } ) + +erroneousIdent = { id_name = "", id_info = nilPtr } + +/* + Some general overloaded parsing routines +*/ + +wantSequence :: !Token !Context !*ParseState -> (!.[a],!*ParseState) | want a +wantSequence separator context pState + # (first, pState) = want pState + (token, pState) = nextToken context pState + | separator == token + # (rest, pState) = wantSequence separator context pState + = ([first : rest], pState) + // otherwise // separator <> token + = ([first], tokenBack pState) +/* +optionalSequence start_token separator context pState + # (token, pState) = nextToken context pState + | token == start_token + = wantSequence separator context pState + = ([], tokenBack pState) +*/ +parseList try_fun pState :== parse_list pState // try_fun * +//parseList try_fun pState = parse_list pState + where + // parse_list :: !*ParseState -> (tree, *ParseState) + parse_list pState + # (succ, tree, pState) = try_fun pState + | succ + # (trees, pState) = parse_list pState + = ([tree : trees], pState) + = ([], pState) + +//wantSepList msg sep_token context try_fun pState = want_list msg pState +wantSepList msg sep_token context try_fun pState :== want_list msg pState // try_fun (sep_token tryfun)* + where + want_list msg pState + # (succ, tree, pState) = try_fun pState + | succ + # (token, pState) = nextToken context pState + | token == sep_token + # (trees, pState) = optSepList sep_token context try_fun pState + = ([tree : trees], pState) + // otherwise // token <> sep_token + = ([tree], tokenBack pState) + # (token, pState) = nextToken GeneralContext pState + = ([tree], parseError "wantList" (Yes token) msg pState) + +//optSepList sep_token context try_fun pState = want_list msg pState +optSepList sep_token context try_fun pState :== want_list pState // [ try_fun (sep_token tryfun)* ] + where + want_list pState + # (succ, tree, pState) = try_fun pState + | succ + # (token, pState) = nextToken context pState + | token == sep_token + # (trees, pState) = want_list pState + = ([tree : trees], pState) + // otherwise // token <> sep_token + = ([tree], tokenBack pState) + = ([], pState) + +//wantList msg try_fun pState = want_list msg pState +wantList msg try_fun pState :== want_list msg pState // try_fun + + where + want_list msg pState + # (succ, tree, pState) = try_fun pState + | succ + # (trees, pState) = parseList try_fun pState + = ([tree : trees], pState) + # (token, pState) = nextToken GeneralContext pState + = ([tree], parseError "wantList" (Yes token) msg pState) +/* +instance want (a,b) | want a & want b +where + want pState + # (x, pState) = want pState + (y, pState) = want pState + = ((x,y), pState) +*/ +wantIdents :: !Context !IdentClass !ParseState -> (![Ident], !ParseState) +wantIdents context ident_class pState + # (first_name, pState) = want pState + (first_ident, pState) = stringToIdent first_name ident_class pState + (token, pState) = nextToken context pState + | token == CommaToken + # (rest, pState) = wantIdents context ident_class pState + = ([first_ident : rest], pState) + = ([first_ident], tokenBack pState) + +optionalPriority :: !Bool !Token !ParseState -> (Priority, !ParseState) +optionalPriority isinfix (PriorityToken prio) pState + = (prio, pState) +optionalPriority isinfix token pState + | isinfix + = (DummyPriority, tokenBack pState) + = (NoPrio, tokenBack pState) + +/* + Modules +*/ + +:: ParseContext :== Int + +cICLContext :== 1 +cGlobalContext :== 2 +cDCLContext :== 0 +cLocalContext :== 1 + +SetGlobalContext iclmodule + | iclmodule + = cICLContext bitor cGlobalContext + = cDCLContext bitor cGlobalContext + +SetLocalContext context :== context bitand (bitnot cGlobalContext) + +isLocalContext context :== context bitand cGlobalContext == 0 +isGlobalContext context :== not (isLocalContext context) + +isDclContext context :== context bitand cICLContext == 0 +isIclContext context :== not (isDclContext context) + +cWantIclFile :== True +cWantDclFile :== False + +wantModule :: !Bool !Ident !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) +wantModule iclmodule file_id=:{id_name} hash_table error searchPaths pre_def_symbols files + # file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") + = case openScanner file_name searchPaths files of + (Yes scanState, files) -> initModule file_name scanState pre_def_symbols files + (No , files) -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in + (False, mod, hash_table, error <<< "Could not open: " <<< file_name, pre_def_symbols, files) +where + initModule :: String ScanState !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) + initModule file_name scanState pre_def_symbols files + # (succ, mod_type, mod_name, scanState) = try_module_header iclmodule scanState + | succ + # pState = { ps_scanState = scanState + , ps_error = { pea_file = error, pea_ok = True } + , ps_skipping = False + , ps_hash_table = hash_table + , ps_pre_def_symbols = pre_def_symbols + } + pState = verify_name mod_name id_name file_name pState + (mod_ident, pState) = stringToIdent mod_name IC_Module pState + pState = check_layout_rule pState + (defs, pState) = want_definitions (SetGlobalContext iclmodule) pState + {ps_scanState,ps_hash_table,ps_error,ps_pre_def_symbols} + = pState +// RWS ... + defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics") + [PD_Import imports \\ PD_Import imports <- defs] + defs +// ... RWS + mod = { mod_name = mod_ident, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs } + = ( ps_error.pea_ok + , mod, ps_hash_table + , ps_error.pea_file + , ps_pre_def_symbols + , closeScanner ps_scanState files + ) + // otherwise // ~ succ + # mod = { mod_name = file_id, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] } + = (False, mod, hash_table, error <<< '[' <<< file_id <<< "]: " <<< "incorrect module header", pre_def_symbols, files) + + try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState) + try_module_header is_icl_mod scanState + # (token, scanState) = nextToken GeneralContext scanState + | is_icl_mod + | token == ModuleToken + # (token, scanState) = nextToken GeneralContext scanState + = try_module_name token MK_Main scanState + | token == ImpModuleToken + = try_module_token MK_Module scanState + | token == SysModuleToken + = try_module_token MK_System scanState + = (False, MK_None, "", tokenBack scanState) + | token == DefModuleToken + = try_module_token MK_Module scanState + | token == SysModuleToken + = try_module_token MK_System scanState + = (False, MK_None, "", tokenBack scanState) + + try_module_token :: !ModuleKind !ScanState -> (!Bool,!ModuleKind!,!String,!ScanState) + try_module_token mod_type scanState + # (token, scanState) = nextToken GeneralContext scanState + | token == ModuleToken + # (token, scanState) = nextToken GeneralContext scanState + = try_module_name token mod_type scanState + = (False, mod_type, "", tokenBack scanState) + + try_module_name (IdentToken name) mod_type scanState + = (True, mod_type, name, scanState) //-->> ("module",name) + try_module_name token mod_type scanState + = (False, mod_type, "", tokenBack scanState) + + verify_name name id_name file_name pState=:{ps_error={pea_file}} + | name == id_name + = pState + # pea_file = pea_file <<< "Module name \"" <<< name <<< "\" does not match file name \"" <<< file_name <<< "\"\n" + = { pState & ps_error = { pea_file = pea_file, pea_ok = False }} + + check_layout_rule pState + # (token, pState) = nextToken GeneralContext pState + use_layout = token <> SemicolonToken && token <> EndOfFileToken // '&& token <> EndOfFileToken' to handle end groups of empty modules + | use_layout = appScanState (setUseLayout use_layout) (tokenBack pState) + = appScanState (setUseLayout use_layout) pState + + want_definitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState) + want_definitions context pState + = want_acc_definitions [] pState + where + want_acc_definitions :: ![ParsedDefinition] !ParseState -> (![ParsedDefinition], !ParseState) + want_acc_definitions acc pState + # (defs, pState) = wantDefinitions context pState + acc = acc ++ defs + pState = wantEndModule pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = (acc, pState) + # pState = parseError "want definitions" (Yes token) "End of file" pState + pState = wantEndOfDefinition "definitions" pState + = want_acc_definitions acc pState +/* + [Definition] on local and global level +*/ + +wantDefinitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState) +wantDefinitions context pState + = parseList (tryDefinition context) pState + +DummyPriority :== Prio LeftAssoc 9 + +cHasPriority :== True +cHasNoPriority :== False + +tryDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState) +tryDefinition context pState + # (token, pState) = nextToken GeneralContext pState + (fname, linenr, pState) = getFileAndLineNr pState + = try_definition context token (LinePos fname linenr) pState +where + try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState) + try_definition context DoubleColonToken pos pState + # (def, pState) = wantTypeDef context pos pState + = (True, def, pState) + try_definition _ ImportToken pos pState +// RWS ... + # (token, pState) = nextToken FunctionContext pState + | token == CodeToken && isIclContext context + # (importedObjects, pState) = wantCodeImports pState + = (True, PD_ImportedObjects importedObjects, pState) + # pState = tokenBack pState +// ... RWS + # (imports, pState) = wantImports pState + = (True, PD_Import imports, pState) + try_definition _ FromToken pos pState + # (imp, pState) = wantFromImports pState + = (True, PD_Import [imp], pState) -->> imp +/* try_definition _ ExportToken pos pState + # (exports, pState) = wantExportDef pState + = (True, PD_Export exports, pState) + try_definition _ ExportAllToken pos pState + = (True, PD_Export ExportAll, pState) +*/ try_definition context ClassToken pos pState + # (classdef, pState) = wantClassDefinition context pos pState + = (True, classdef, pState) + try_definition context InstanceToken pos pState + # (instdef, pState) = wantInstanceDeclaration context pos pState + = (True, instdef, pState) + try_definition context token pos pState + | isLhsStartToken token + # (lhs, pState) = want_lhs_of_def token pState + (token, pState) = nextToken FunctionContext pState + (def, pState) = want_rhs_of_def context lhs token (determine_position lhs pos) pState //-->> token + = (True, def, pState) -->> def + with + determine_position (Yes (name, _), _) (LinePos f l) = FunPos f l name.id_name + determine_position lhs pos = pos + = (False, abort "no def(1)", tokenBack pState) + + want_lhs_of_def :: !Token !ParseState -> (!(Optional (Ident, Bool), ![ParsedExpr]), !ParseState) + want_lhs_of_def token pState + # (succ, fname, is_infix, pState) = try_function_symbol token pState + | succ + # (args, pState) = parseList trySimpleLhsExpression pState + = ((Yes (fname, is_infix), args), pState) + # (_, exp, pState) = trySimpleLhsExpression pState + = ((No, [exp]), pState) + where + try_function_symbol :: !Token !ParseState -> (!Bool, Ident, !Bool, !ParseState) // (Success, Ident, Infix, ParseState) + try_function_symbol (IdentToken name) pState + # (id, pState) = stringToIdent name IC_Expression pState + = (True, id, False, pState) + try_function_symbol OpenToken pState + # (token, pState) = nextToken FunctionContext pState + = case token of + (IdentToken name) + # (token, pState) = nextToken FunctionContext pState + | CloseToken == token + # (id, pState) = stringToIdent name IC_Expression pState + -> (True, id, True, pState) + -> (False, abort "no name", False, tokenBack (tokenBack (tokenBack pState))) + _ + -> (False, abort "no name", False, tokenBack (tokenBack pState)) + try_function_symbol token pState + = (False, abort "name", False, tokenBack pState) + + want_rhs_of_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState) + want_rhs_of_def context (opt_name, args) DoubleColonToken pos pState + # (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState + (tspec, pState) = want pState // SymbolType + | isDclContext context + # (specials, pState) = optionalSpecials pState + = (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition (1)" pState) + = (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition (2)" pState) + want_rhs_of_def context (opt_name, args) (PriorityToken prio) pos pState + # (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState + (token, pState) = nextToken TypeContext pState + | token == DoubleColonToken + # (tspec, pState) = want pState + | isDclContext context + # (specials, pState) = optionalSpecials pState + = (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition (3)" pState) + = (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition (4)" pState) + = (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState)) + want_rhs_of_def context (No, args) token pos pState + # pState = want_node_def_token pState token + (rhs, pState) = wantRhs isEqualToken (tokenBack pState) + | isGlobalContext context + = (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState) + = (PD_NodeDef pos (combine_args args) rhs, pState) + where + want_node_def_token s EqualToken = s + want_node_def_token s DefinesColonToken = replaceToken EqualToken s + want_node_def_token s token = parseError "RHS" (Yes token) "defines token (= or =:)" s + + combine_args [arg] = arg + combine_args args = PE_List args + want_rhs_of_def context (Yes (name, False), []) token pos pState + | isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) + # (rhs, pState) = wantRhs (\_ -> True) (tokenBack pState) + = (PD_NodeDef pos (PE_Ident name) rhs, pState) + want_rhs_of_def context (Yes (name, is_infix), args) token pos pState + # (fun_kind, code_allowed, pState) = token_to_fun_kind pState token + (token, pState) = nextToken FunctionContext pState + | isIclContext context && token == CodeToken + # (rhs, pState) = wantCodeRhs pState + | code_allowed + = (PD_Function pos name is_infix args rhs fun_kind, pState) + // otherwise // ~ code_allowed + = (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState) + # pState = tokenBack (tokenBack pState) + (rhs, pState) = wantRhs isRhsStartToken pState + = case fun_kind of + FK_Function | isDclContext context + -> (PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState) + FK_Caf | ~(isEmpty args) + -> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState) + _ -> (PD_Function pos name is_infix args rhs fun_kind, pState) + where + token_to_fun_kind s BarToken = (FK_Function, False, s) + token_to_fun_kind s (SeqLetToken _) = (FK_Function, False, s) + token_to_fun_kind s EqualToken = (FK_Function, True, s) + token_to_fun_kind s ColonDefinesToken = (FK_Macro, False, s) + token_to_fun_kind s DoubleArrowToken = (FK_Function, True, s) + token_to_fun_kind s DefinesColonToken = (FK_Caf, False, s) + token_to_fun_kind s token = (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s) + + check_name_and_fixity No hasprio pState + = (erroneousIdent, False, parseError "Definition" No "identifier" pState) + check_name_and_fixity (Yes (name,is_infix)) hasprio pState + | not is_infix && hasprio // XXXXXXX + = (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState) + = (name, is_infix, pState) + +isEqualToken :: !Token -> Bool +isEqualToken EqualToken = True +isEqualToken _ = False + +isRhsStartToken :: !Token -> Bool +isRhsStartToken EqualToken = True +isRhsStartToken ColonDefinesToken = True +isRhsStartToken DefinesColonToken = True +isRhsStartToken _ = False + +optionalSpecials :: !ParseState -> (!Specials, !ParseState) +optionalSpecials pState + # (token, pState) = nextToken TypeContext pState + | token == SpecialToken + # (specials, pState) = wantList "<special statement>" try_substitutions pState + = (SP_ParsedSubstitutions specials, wantEndGroup "specials" pState) + // otherwise // token <> SpecialToken + = (SP_None, tokenBack pState) +where + try_substitutions pState + # (succ, type_var, pState) = tryTypeVar pState + | succ + # (subst, pState) = want_rest_substitutions type_var pState + = (True, subst, wantEndOfDefinition "substitution" pState) + = (False, [], pState) + + want_rest_substitutions type_var pState + # pState = wantToken GeneralContext "specials" EqualToken pState + (type, pState) = want pState + (token, pState) = nextToken GeneralContext pState + | token == CommaToken + # (next_type_var, pState) = want pState + (substs, pState) = want_rest_substitutions next_type_var pState + = ([{ bind_src = type, bind_dst = type_var } : substs], pState) + = ([{ bind_src = type, bind_dst = type_var }], tokenBack pState) +/* + For parsing right-hand sides of functions only +*/ + +wantCodeRhs :: !ParseState -> (Rhs, !ParseState) +wantCodeRhs pState + # (expr, pState) = want_code_expr pState + = ( { rhs_alts = UnGuardedExpr + { ewl_nodes = [] + , ewl_locals = LocalParsedDefs [] + , ewl_expr = expr + } + , rhs_locals = LocalParsedDefs [] + } + , wantEndOfDefinition "code rhs" pState + ) +where + want_code_expr :: !ParseState -> (!ParsedExpr, !ParseState) + want_code_expr pState + # (token, pState) = nextToken CodeContext pState + = case token of + OpenToken + # (input, pState) = want_bindings [] True pState + pState = wantToken CodeContext "input bindings of code block" CloseToken pState + pState = wantToken CodeContext "output bindings of code block" OpenToken pState + (out, pState) = want_bindings [] False pState + pState = wantToken CodeContext "output bindings of code block" CloseToken pState + (token, pState) = nextToken CodeContext pState + -> case token of + CodeBlockToken the_code + -> (PE_Any_Code input out the_code, pState) + _ -> (PE_Any_Code input out [] , parseError "code rhs (any code)" (Yes token) "code block" pState) + InlineToken + # (token, pState) = nextToken CodeContext pState + -> case token of + CodeBlockToken the_code + -> (PE_ABC_Code the_code True, pState) + token + -> (PE_ABC_Code [] True, parseError "inline code" (Yes token) "code block" pState) + CodeBlockToken the_code + -> (PE_ABC_Code the_code False, pState) + token + -> (PE_Empty, parseError "code rhs" (Yes token) "<code rhs>" pState) + + want_bindings :: !(CodeBinding Ident) !Bool !ParseState -> (!CodeBinding Ident, !ParseState) + want_bindings acc mayBeEmpty pState + # (token, pState) = nextToken CodeContext pState + = case token of + IdentToken name + # (token, pState) = nextToken CodeContext pState + | token == EqualToken || token == DefinesColonToken + # (token, pState) = nextToken CodeContext pState + -> case token of + IdentToken value + # (ident, pState) = stringToIdent name IC_Expression pState + acc = [{ bind_dst = ident, bind_src = value }: acc] + (token, pState) = nextToken CodeContext pState + | token == CommaToken + -> want_bindings acc mayBeEmpty pState + // token <> CommaToken + -> (reverse acc, tokenBack pState) + token + -> (acc, parseError "bindings in code block" (Yes token) "value" pState) + // token <> EqualToken && token <> DefinesColonToken + -> (acc, parseError "bindings in code block" (Yes token) "= or =:" pState) + CloseToken + | mayBeEmpty + -> (acc, tokenBack pState) // to handle empty input bindings + -> (acc, parseError "code bindings" (Yes token) "output bindings" pState) + token + -> (acc, parseError "bindings in code block" (Yes token) "identifier" pState) +/* + For parsing right-hand sides of functions and case expressions +*/ + + +/* Syntax: + FunctionAltDefRhs = FunctionBody // Rhs + [ LocalFunctionAltDefs ] + FunctionBody = exprWithLocals // OptGuardedAlts : GuardedAlts + | GuardedAlts // : UnGuardedExpr + GuardedAlts = { [ LetBefore ] '|' [ StrictLet ] Guard FunctionBody }+ [ ExprWithLocals ] + ExprWithLocals = [ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ] +*/ + +wantRhs :: !(!Token -> Bool) !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs +wantRhs separator pState + # (alts, pState) = want_LetsFunctionBody separator pState + (locals, pState) = optionalLocals WhereToken pState + = ({ rhs_alts = alts, rhs_locals = locals}, pState) +where + want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + want_LetsFunctionBody sep pState + # (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [] sep pState + + want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + want_FunctionBody BarToken nodeDefs alts sep pState +// # (lets, pState) = want_StrictLet pState // removed from 2.0 + # (token, pState) = nextToken FunctionContext pState + | token == OtherwiseToken + # (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token pState + = case token of + BarToken + # pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState + -> root_expression token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState + _ -> root_expression token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState + | token == LetToken True + # pState = parseError "RHS" No "No 'let!' in this version of Clean" pState + = root_expression token nodeDefs (reverse alts) sep pState + # (guard, pState) = wantRhsExpressionT token pState + (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token pState + | token == BarToken // nested guard + # (position, pState) = getPosition pState + offside = position.fp_col + (expr, pState) = want_FunctionBody token nodeDefs2 [] sep pState + pState = wantEndNestedGuard (default_found expr) offside pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [alt:alts] sep pState + // otherwise + # (expr, pState) = root_expression token nodeDefs2 [] sep pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [alt:alts] sep pState + want_FunctionBody token nodeDefs alts sep pState + = root_expression token nodeDefs (reverse alts) sep pState + + root_expression :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + root_expression token nodeDefs [] sep pState + # (expr,pState) = want_OptExprWithLocals token nodeDefs sep pState + = case expr of + Yes expr -> ( UnGuardedExpr expr, pState) + No -> ( UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs []} + , parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState + ) + root_expression token nodeDefs alts sep pState + # (expr,pState) = want_OptExprWithLocals token nodeDefs sep pState + = (GuardedAlts alts expr, pState) + + default_found (GuardedAlts _ No) = False + default_found _ = True + + want_OptExprWithLocals :: !Token ![NodeDefWithLocals] !(Token -> Bool) !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState) + want_OptExprWithLocals DoubleArrowToken nodeDefs sep pState + = want_OptExprWithLocals EqualToken nodeDefs sep (replaceToken EqualToken pState) + want_OptExprWithLocals token nodeDefs sep pState + | sep token + # (expr, pState) = wantExpression cIsNotAPattern pState + pState = wantEndRootExpression pState + (locals,pState) = optionalLocals WithToken pState + = ( Yes { ewl_nodes = nodeDefs + , ewl_expr = expr + , ewl_locals = locals + } + , pState + ) + = (No, tokenBack pState) + +/* want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !? + want_StrictLet pState + # (token, pState) = nextToken FunctionContext pState + | token == LetToken True + # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef True) pState + pState = wantToken FunctionContext "strict let" InToken pState + = (let_defs, pState) + = ([], tokenBack pState) +*/ + want_LetBefores :: !Token !ParseState -> (![NodeDefWithLocals], !Token, !ParseState) + want_LetBefores (SeqLetToken strict) pState + # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef strict) pState + (token, pState) = nextToken FunctionContext pState + (token, pState) = opt_End_Group token pState + (more_let_defs, token, pState) = want_LetBefores token pState + = (let_defs ++ more_let_defs, token, pState) + where + opt_End_Group token pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + | token == EndGroupToken + = nextToken FunctionContext pState + // otherwise // token <> EndGroupToken + = (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState) + | otherwise // not ss_useLayout + = (token, pState) + want_LetBefores token pState + = ([], token, pState) + + try_LetDef :: !Bool !ParseState -> (!Bool, NodeDefWithLocals, !ParseState) + try_LetDef strict pState + # (succ, lhs_exp, pState) = trySimpleLhsExpression pState + | succ + # pState = wantToken FunctionContext "let definition" EqualToken pState + (rhs_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp) + (locals , pState) = optionalLocals WithToken pState + = ( True + , { ndwl_strict = strict + , ndwl_def = { bind_dst = lhs_exp + , bind_src = rhs_exp + } + , ndwl_locals = locals + } + , pState + ) + // otherwise // ~ succ + = (False, abort "no definition", pState) + +optionalLocals :: !Token !ParseState -> (!LocalDefs, !ParseState) +optionalLocals dem_token pState + # (off_token, pState) = nextToken FunctionContext pState + | dem_token == off_token + = wantLocals pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | off_token == CurlyOpenToken && ~ ss_useLayout + = wantLocals (tokenBack pState) + // otherwise + = (LocalParsedDefs [], tokenBack pState) + +wantLocals :: !ParseState -> (LocalDefs, !ParseState) +wantLocals pState + # pState = wantBeginGroup "local definitions" pState + (defs, pState) = wantDefinitions cLocalContext pState + = (LocalParsedDefs defs, wantEndLocals pState) + +/* + imports and exports +*/ + +wantImports :: !ParseState -> (![ParsedImport], !ParseState) +wantImports pState + # (names, pState) = wantIdents FunctionContext IC_Module pState + (file_name, line_nr, pState) = getFileAndLineNr pState + pState = wantEndOfDefinition "imports" pState + = (map (\name -> { import_module = name, import_symbols = [], import_file_position = (file_name, line_nr)}) names, pState) + +wantFromImports :: !ParseState -> (!ParsedImport, !ParseState) +wantFromImports pState + # (mod_name, pState) = want pState + (mod_ident, pState) = stringToIdent mod_name IC_Module pState + pState = wantToken GeneralContext "from imports" ImportToken pState + (file_name, line_nr, pState) = getFileAndLineNr pState + (import_symbols, pState) = wantSequence CommaToken GeneralContext pState + pState = wantEndOfDefinition "from imports" pState + = ( { import_module = mod_ident, import_symbols = import_symbols, import_file_position = (file_name, line_nr) }, pState) + +// RWS ... +instance want ImportedObject where + want pState + # (token, pState) = nextToken GeneralContext pState + | token == IdentToken "library" + # (token, pState) = nextToken GeneralContext pState + = want_import_string token cIsImportedLibrary pState + = want_import_string token cIsImportedObject pState + where + want_import_string :: Token Bool ParseState -> (ImportedObject, ParseState) + want_import_string (StringToken string) isLibrary pState + = ({io_is_library = isLibrary, io_name = string}, pState) + want_import_string token isLibrary pState + = ({io_is_library = isLibrary, io_name = ""}, parseError "import code declaration" (Yes token) "imported item" pState) + +wantCodeImports :: !ParseState -> (![ImportedObject], !ParseState) +wantCodeImports pState + # pState = wantToken GeneralContext "import code declaration" FromToken pState + (importObjects, pState) = wantSequence CommaToken GeneralContext pState + = (importObjects, wantEndOfDefinition "import code declaration" pState) +// ... RWS + +instance want ImportDeclaration +where + want pState + # (token, pState) = nextToken GeneralContext pState + = case token of + DoubleColonToken + # (name, pState) = wantUpperCaseName "import type" pState + (type_id, pState) = stringToIdent name IC_Type pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (conses, pState) = want_names (wantUpperCaseName "import type (..)") IC_Expression CloseToken pState + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState) + | token == CurlyOpenToken + # (fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState + -> (ID_Record { ii_ident = type_id, ii_extended = ii_extended } (Yes fields), pState) + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } No, tokenBack pState) + ClassToken + # (name, pState) = want pState + (class_id, pState) = stringToIdent name IC_Class pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (members, pState) = want_names want IC_Expression CloseToken pState + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } (Yes members), pState) + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } No, pState) + InstanceToken + # (class_name, pState) = want pState + (ii_extended, pState) = optional_extension pState + (types, pState) = wantList "instance types" tryBrackType pState + (class_id, pState) = stringToIdent class_name IC_Class pState + (inst_id, pState) = stringToIdent class_name (IC_Instance types) pState + (context, pState) = optionalContext pState + -> (ID_Instance { ii_ident = class_id, ii_extended = ii_extended } inst_id (types,context), pState) + IdentToken fun_name + # (fun_id, pState) = stringToIdent fun_name IC_Expression pState + (ii_extended, pState) = optional_extension pState + -> (ID_Function { ii_ident = fun_id, ii_extended = ii_extended }, pState) + token + # (fun_id, pState) = stringToIdent "dummy" IC_Expression pState + -> ( ID_Function { ii_ident = fun_id, ii_extended = False } + , parseError "from import" (Yes token) "imported item" pState + ) + where + want_names want_fun ident_kind close_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = ([], wantToken FunctionContext "import declaration" close_token pState) + = want_list_of_names want_fun ident_kind close_token (tokenBack pState) + + want_list_of_names want_fun ident_kind close_token pState + # (name, pState) = want_fun pState + (name_id, pState) = stringToIdent name ident_kind pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == CommaToken + # (names, pState) = want_list_of_names want_fun ident_kind close_token pState + = ([{ ii_ident = name_id, ii_extended = ii_extended } : names], pState) + | token == close_token + = ([{ ii_ident = name_id, ii_extended = ii_extended }], pState) + = ([{ ii_ident = name_id, ii_extended = ii_extended }], parseError "ImportDeclaration" (Yes token) ")" pState) + + optional_extension pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = (True, pState) + = (False, tokenBack pState) + + optional_extension_with_next_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + # (token, pState) = nextToken FunctionContext pState + = (True, token, pState) + = (False, token, pState) + +/* +wantExportDef :: !ParseState -> (!Export, !ParseState) +wantExportDef pState + # (name, pState) = want pState + (ident, pState) = stringToIdent name IC_Class pState + (types, pState) = wantList "instance types" trySimpleType pState + pState = wantEndOfDefinition "exports" pState + = ({ export_class = ident, export_types = types}, pState) +*/ +/* + Classes and instances +*/ + +cIsAGlobalContext :== True +cIsNotAGlobalContext :== False + +cMightBeAClass :== True +cIsNotAClass :== False + + +wantClassDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) +wantClassDefinition context pos pState + # (might_be_a_class, class_or_member_name, prio, pState) = want_class_or_member_name pState + (class_variables, pState) = wantList "class variable(s)" try_class_variable pState + (class_arity, class_args, class_cons_vars) = convert_class_variables class_variables 0 0 + (contexts, pState) = optionalContext pState + (token, pState) = nextToken TypeContext pState + | token == DoubleColonToken + = want_overloaded_function pos class_or_member_name prio class_arity class_args class_cons_vars contexts pState + | might_be_a_class + | token == WhereToken + # (class_id, pState) = stringToIdent class_or_member_name IC_Class pState + (members, pState) = wantDefinitions context pState + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + = (PD_Class class_def members, wantEndGroup "class" pState) + | isEmpty contexts + = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>: contexts" pState) + // otherwise + # pState = tokenBack pState + (class_id, pState) = stringToIdent class_or_member_name IC_Class pState + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + pState = wantEndOfDefinition "class definition" pState + = (PD_Class class_def [], pState) + = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>" pState) + where + want_class_or_member_name pState + # (token, pState) = nextToken TypeContext pState + | token == OpenToken + # (member_name, pState) = want pState + pState = wantToken GeneralContext "class definition" CloseToken pState + (token, pState) = nextToken FunctionContext pState + (prio, pState) = optionalPriority cIsInfix token pState + = (cIsNotAClass, member_name, prio, pState) + # (class_name, pState) = want_name token pState + = (cMightBeAClass, class_name, NoPrio, pState) + where + want_name (IdentToken name) pState + = (name, pState) + want_name token pState + = ("", parseError "Class Definition" (Yes token) "<identifier>" pState) + + want_overloaded_function pos member_name prio class_arity class_args class_cons_vars contexts pState + # (tspec, pState) = want pState + (member_id, pState) = stringToIdent member_name IC_Expression pState + (class_id, pState) = stringToIdent member_name IC_Class pState + member = PD_TypeSpec pos member_id prio (Yes tspec) SP_None + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + pState = wantEndOfDefinition "overloaded function" pState + = (PD_Class class_def [member], pState) + + try_class_variable pState + # (token, pState) = nextToken TypeContext pState + | token == DotToken + # (type_var, pState) = wantTypeVar pState + = (True, (True, type_var), pState) + # (succ, type_var, pState) = tryTypeVarT token pState + = (succ, (False, type_var), pState) + + convert_class_variables [] arg_nr cons_vars + = (arg_nr, [], cons_vars) + convert_class_variables [(annot, var) : class_vars] arg_nr cons_vars + # (arity, class_vars, cons_vars) = convert_class_variables class_vars (inc arg_nr) cons_vars + | annot + = (arity, [var : class_vars], cons_vars bitor (1 << arg_nr)) + = (arity, [var : class_vars], cons_vars) + +// Sjaak ... +wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) +wantInstanceDeclaration context pi_pos pState + # (class_name, pState) = want pState + (pi_class, pState) = stringToIdent class_name IC_Class pState + ((pi_types, pi_context), pState) = want_instance_type pState + (pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState + | isIclContext context + # pState = wantToken FunctionContext "instance declaration" WhereToken pState + pState = wantBeginGroup "instance" pState + (pi_members, pState) = wantDefinitions context pState + pState = wantEndLocals pState + + = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, + pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos }, pState) + // otherwise // ~ (isIclContext context) + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (pi_types_and_contexts, pState) = want_instance_types pState + (idents, pState) = seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState + = (PD_Instances +// [ { pi_class = pi_class, pi_ident = pi_ident, pi_types = type, pi_context = context // voor martin + [ { pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context + , pi_members = [], pi_specials = SP_None, pi_pos = pi_pos} + \\ (type,context) <- [ (pi_types, pi_context) : pi_types_and_contexts ] + & ident <- [ pi_ident : idents ] + ] + , pState + ) + // otherwise // token <> CommaToken + # (specials, pState) = optionalSpecials (tokenBack pState) + pState = wantEndOfDefinition "instance declaration" pState + = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, + pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState) +// ... Sjaak +where + want_instance_type pState + # (pi_types, pState) = wantList "instance types" tryBrackType pState +// # (pi_types, pState) = wantList "instance types" tryType pState // This accepts 1.3 syntax, but is wrong for multiparameter classes + (pi_context, pState) = optionalContext pState + = ((pi_types, pi_context), pState) + want_instance_types pState + # (type_and_context, pState) = want_instance_type pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (types, pState) = want_instance_types pState + = ([type_and_context:types], pState) + // otherwise // token <> CommaToken + = ([type_and_context], pState) + +optionalContext :: !ParseState -> ([TypeContext],ParseState) +optionalContext pState + # (token, pState) = nextToken TypeContext pState + | token == BarToken + = want_contexts pState + = ([], tokenBack pState) +where + want_contexts pState + # (contexts, pState) = want_context pState + (token, pState) = nextToken TypeContext pState + | token == AndToken + # (more_contexts, pState) = want_contexts pState + = (contexts ++ more_contexts, pState) + = (contexts, tokenBack pState) + + want_context pState + # (class_names, pState) = wantSequence CommaToken TypeContext pState + (types, pState) = wantList "type arguments" tryBrackType pState + = build_contexts class_names types (length types) pState + where + build_contexts [] types arity pState + = ([], pState) + build_contexts [class_name : class_names] types arity pState + # (contexts, pState) = build_contexts class_names types arity pState + (class_ident, pState) = stringToIdent class_name IC_Class pState + tc_class = { glob_object = MakeDefinedSymbol class_ident NoIndex (length types), glob_module = NoIndex } + = ([{ tc_class = tc_class, tc_types = types, tc_var = nilPtr } : contexts], pState) + +optionalCoercions :: !ParseState -> ([AttrInequality], ParseState) +optionalCoercions pState + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (token, pState) = nextToken TypeContext pState + | token == SquareOpenToken + # (inequals, pState) = want_inequalities pState + = (inequals, wantToken FunctionContext "coercions" SquareCloseToken pState) + = ([], parseError "Function type: coersions" (Yes token) "[" pState) + = ([], tokenBack pState) + where + want_inequalities pState + # (token, pState) = nextToken TypeContext pState + (_, inequals, pState) = want_attr_inequality token pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (more_inequals, pState) = want_inequalities pState + = (inequals ++ more_inequals, pState) + = (inequals, tokenBack pState) + want_attr_inequality (IdentToken var_name) pState + | isLowerCaseName var_name + # (off_ident, pState) = stringToIdent var_name IC_TypeAttr pState + (token, pState) = nextToken TypeContext pState + | token == LessThanOrEqualToken + # (var_name, pState) = wantLowerCaseName "attribute inequality" pState + (dem_ident, pState) = stringToIdent var_name IC_TypeAttr pState + ai_demanded = makeAttributeVar dem_ident + = (ai_demanded, [{ ai_demanded = ai_demanded, ai_offered = makeAttributeVar off_ident }], pState) + # (ai_demanded, inequals, pState) = want_attr_inequality token pState + = (ai_demanded, [{ ai_demanded = ai_demanded, ai_offered = makeAttributeVar off_ident } : inequals], pState) + want_attr_inequality token pState + # erroneous_attr_var = makeAttributeVar erroneousIdent + = ( erroneous_attr_var + , [{ ai_demanded = erroneous_attr_var, ai_offered = erroneous_attr_var }] + , parseError "Function type: optional coercions" (Yes token) "<attribute variable>" pState + ) + +/* + Type definitions +*/ + +wantTypeVar :: ! ParseState -> (!TypeVar, !ParseState) +wantTypeVar pState + # (succ, type_var, pState) = tryTypeVar pState + | succ + = (type_var, pState) + # (token, pState) = nextToken TypeContext pState + = (MakeTypeVar erroneousIdent, parseError "Type Variable" (Yes token) "type variable" pState) + +tryAttributedTypeVar :: !ParseState -> (!Bool, ATypeVar, !ParseState) +tryAttributedTypeVar pState + # (token, pState) = nextToken TypeContext pState + | is_type_arg_token token + # (aOrA, annot, attr, pState) = optionalAnnotAndAttr (tokenBack pState) + (succ, type_var, pState) = tryTypeVar pState + | succ + = (True, { atv_attribute = attr, atv_annotation = annot, atv_variable = type_var }, pState) + | aOrA // annot <> AN_None || attr <> TA_None + # (token, pState) = nextToken TypeContext pState + = (False, no_type_var, parseError "Attributed type var" (Yes token) "type variabele after annotation or attribute" pState) + // otherwise + = (False, no_type_var, tokenBack pState) + // otherwise + = (False, no_type_var, tokenBack pState) +where + is_type_arg_token (IdentToken t) = isLowerCaseName t + is_type_arg_token DotToken = True + is_type_arg_token AsteriskToken = True + is_type_arg_token t = False + + no_type_var = abort "tryAttributedTypeVar: No type var" + +wantTypeDef :: !ParseContext !Position !ParseState -> (ParsedDefinition, !ParseState) +wantTypeDef context pos pState + # (type_lhs, annot, pState) = want_type_lhs pos pState + (token, pState) = nextToken TypeContext pState + (def, pState) = want_type_rhs context type_lhs token annot pState + pState = wantEndOfDefinition "type definition (6)" pState + = (def, pState) +where + want_type_lhs :: !Position !ParseState -> (!ParsedTypeDef, !Annotation, !ParseState) + want_type_lhs pos pState + # (_, annot, attr, pState) = optionalAnnotAndAttr pState + (name, pState) = wantConstructorName "Type name" pState + (ident, pState) = stringToIdent name IC_Type pState // -->> ("Type name",name) + (args, pState) = parseList tryAttributedTypeVar pState + (contexts, pState) = optionalContext pState + = (MakeTypeDef ident args (ConsList []) attr contexts pos, annot, pState) + + want_type_rhs :: !ParseContext !ParsedTypeDef !Token !Annotation !ParseState -> (ParsedDefinition, !ParseState) + want_type_rhs context td=:{td_name,td_attribute} EqualToken annot pState + # name = td_name.id_name + pState = verify_annot_attr annot td_attribute name pState + (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState + (token, pState) = nextToken TypeContext pState + (token, pState) = case token of // Make the ':' optional for now to handle 1.3 files + ColonToken -> nextToken TypeContext (parseWarning "type RHS" ":-symbol after extential quantified variable should be removed" pState) + _ -> (token, pState) + = case token of + CurlyOpenToken + # (fields, pState) = wantFields td_name pState + pState = wantToken TypeContext "record type def" CurlyCloseToken pState + (rec_cons_ident, pState) = stringToIdent ("_" + name) IC_Expression pState + -> (PD_Type { td & td_rhs = SelectorList rec_cons_ident exi_vars fields }, pState) + ColonToken + | isEmpty exi_vars + -> (PD_Erroneous, parseError "Algebraic type" No "no colon, :," pState) + -> (PD_Erroneous, parseError "Algebraic type" No "in this version of Clean no colon, :, after quantified variables" pState) + _ + # (condefs, pState) = want_constructor_list exi_vars token pState + td = { td & td_rhs = ConsList condefs } + | annot == AN_None + -> (PD_Type td, pState) + -> (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState) + want_type_rhs context td=:{td_attribute} ColonDefinesToken annot pState // type Macro + # name = td.td_name.id_name + pState = verify_annot_attr annot td_attribute name pState + (atype, pState) = want pState // Atype + td = {td & td_rhs = TypeSpec atype} + | annot == AN_None + = (PD_Type td, pState) + = (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState) + want_type_rhs context td=:{td_attribute} token annot pState + | isIclContext context + = (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState) + | td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None + # (td_attribute, properties) = determine_properties annot td_attribute + # td = { td & td_attribute = td_attribute, td_rhs = EmptyRhs properties} + = (PD_Type td, tokenBack pState) + # name = td.td_name.id_name + = (PD_Type { td & td_rhs = EmptyRhs cAllBitsClear}, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState)) + + verify_annot_attr :: !Annotation !TypeAttribute !String !ParseState -> ParseState + verify_annot_attr annot attr name pState + | annot <> AN_None + = parseError "type definition" No ("No annotation, "+toString annot+", in the lhs of type "+name) pState + | attr == TA_None || attr == TA_Unique + = pState + = parseError "ty[e definition" No ("No attribute, "+toString attr+", in the lhs of type "+name) pState + + determine_properties :: !Annotation !TypeAttribute -> (!TypeAttribute, !BITVECT) + determine_properties annot attr + | annot == AN_Strict + | attr == TA_Anonymous + = (TA_None, cIsHyperStrict) + = (attr, cIsHyperStrict bitor cIsNonCoercible) + | attr == TA_Anonymous + = (TA_None, cAllBitsClear) + = (attr, cIsNonCoercible) + + want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState) + want_constructor_list exi_vars token pState + # (pc_cons_name, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState + (pc_arg_types, pState) = parseList tryBrackAType pState + cons = { pc_cons_name = pc_cons_name, pc_arg_types = pc_arg_types, pc_cons_arity = length pc_arg_types, + pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} + (token, pState) = nextToken TypeContext pState + | token == BarToken + # (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState + (token, pState) = nextToken TypeContext pState + (cons_list, pState) = want_constructor_list exi_vars token pState + = ([cons : cons_list], pState) + // otherwise + = ([cons], tokenBack pState) + where + want_cons_name_and_prio :: !Token !ParseState -> (Ident, !Priority, !Position, !ParseState) + want_cons_name_and_prio tok=:(IdentToken name) pState + # (ident, pState) = stringToIdent name IC_Expression pState + (fname, linenr, pState) = getFileAndLineNr pState + (token, pState) = nextToken TypeContext pState + (prio, pState) = optionalPriority cIsNotInfix token pState + | isLowerCaseName name + = (ident, prio, LinePos fname linenr, parseError "Algebraic type: constructor definitions" (Yes tok) "constructor name" pState) + = (ident, prio, LinePos fname linenr, pState) + want_cons_name_and_prio OpenToken pState + # (name, pState) = wantConstructorName "infix constructor" pState + (fname, linenr, pState) = getFileAndLineNr pState + (ident, pState) = stringToIdent name IC_Expression pState + (token, pState) = nextToken TypeContext (wantToken TypeContext "type: constructor and prio" CloseToken pState) + (prio, pState) = optionalPriority cIsInfix token pState + = (ident, prio, LinePos fname linenr, pState) + want_cons_name_and_prio token pState + = (erroneousIdent, NoPrio, NoPos, parseError "Algebraic type: constructor list" (Yes token) "constructor name" pState) + +makeAttributeVar name :== { av_name = name, av_info_ptr = nilPtr } + +optionalAnnotAndAttr :: !ParseState -> (!Bool, !Annotation, !TypeAttribute, !ParseState) +optionalAnnotAndAttr pState + # (token, pState) = nextToken TypeContext pState + | token == ExclamationToken + # (token, pState) = nextToken TypeContext pState + (_ , attr, pState) = optional_attribute token pState + = (True, AN_Strict, attr, pState) + | otherwise // token <> ExclamationToken + # (succ, attr, pState) = optional_attribute token pState + = (succ, AN_None, attr, pState) +where + optional_attribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState) + optional_attribute DotToken pState = (True, TA_Anonymous, pState) + optional_attribute AsteriskToken pState = (True, TA_Unique, pState) + optional_attribute (IdentToken id) pState + | isLowerCaseName id + # (token, pState) = nextToken TypeContext pState + | ColonToken == token + # (ident, pState) = stringToIdent id IC_TypeAttr pState + = (True, TA_Var (makeAttributeVar ident), pState) + = (False, TA_None, tokenBack (tokenBack pState)) + optional_attribute _ pState = (False, TA_None, tokenBack pState) + + +cIsInfix :== True +cIsNotInfix :== False + +wantFields :: !Ident !*ParseState -> (![ParsedSelector], !*ParseState) +wantFields record_type pState + # (field, pState) = want_field record_type pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (fields, pState) = wantFields record_type pState + = ([field : fields], pState) + = ([field], tokenBack pState) + where + want_field :: !Ident !*ParseState -> *(!ParsedSelector, !*ParseState) + want_field record_type pState + # (field_name, pState) = wantLowerCaseName "record field" pState + (fname, linenr, pState) = getFileAndLineNr pState + (ps_field_name, pState) = stringToIdent field_name (IC_Field record_type) pState + (ps_selector_name, pState) = stringToIdent field_name IC_Selector pState + (ps_field_var, pState) = stringToIdent field_name IC_Expression pState + pState = wantToken TypeContext "record field" DoubleColonToken pState + (ps_field_type, pState) = want pState + = ({ ps_field_name = ps_field_name, ps_selector_name = ps_selector_name, ps_field_type = ps_field_type, ps_field_var = ps_field_var, + ps_field_pos = LinePos fname linenr}, pState) + +makeSymbolType args result context attr_env :== + { st_vars = [], st_args = args, st_arity = length args, st_result = result, + st_context = context, st_attr_env = attr_env, st_attr_vars = [] } + +instance want SymbolType +where + want pState + # (types, pState) = parseList tryBrackAType pState + (token, pState) = nextToken TypeContext pState //-->> ("arg types:",types) + (tspec, pState) = want_rest_of_symbol_type token types pState + = (tspec, pState) + where + want_rest_of_symbol_type :: !Token ![AType] !ParseState -> (SymbolType, !ParseState) + want_rest_of_symbol_type ArrowToken types pState + # (type, pState) = want pState + (context, pState) = optionalContext pState + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType types type context attr_env, pState) + want_rest_of_symbol_type token [] pState + = (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "type" pState) + want_rest_of_symbol_type token [type] pState + # (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token [type=:{at_type = TA type_symb []} : types] pState + # type = { type & at_type = TA { type_symb & type_arity = length types } types } + (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token [type=:{at_type = TV tv} : types] pState + # type = { type & at_type = CV tv :@: types } + (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token types pState + = (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "->" pState) -->> types + +/* + Types +*/ + +nameToTypeVar name pState + # last_char_index = size name - 1 + | name.[last_char_index] == '^' + # new_name = name % (0, last_char_index - 1) + # (ident, pState) = stringToIdent new_name IC_Type pState + = (GTV (MakeTypeVar ident), pState) + # (ident, pState) = stringToIdent name IC_Type pState + = (TV (MakeTypeVar ident), pState) + +instance want TypeVar +where + want pState + # (token, pState) = nextToken TypeContext pState + = case token of + IdentToken name + | isLowerCaseName name + # (ident, pState) = stringToIdent name IC_Type pState + -> (MakeTypeVar ident, pState) + -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) + _ + -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) + +adjustAttribute :: !TypeAttribute Type *ParseState -> (TypeAttribute,*ParseState) +adjustAttribute TA_Anonymous (TV {tv_name={id_name}}) pState + # (ident, pState) = stringToIdent id_name IC_TypeAttr pState + = (TA_Var (makeAttributeVar ident), pState) +adjustAttribute TA_Anonymous (GTV {tv_name={id_name}}) pState + # (ident, pState) = stringToIdent id_name IC_TypeAttr pState + = (TA_Var (makeAttributeVar ident), pState) +adjustAttribute attr type pState + = (attr, pState) + +stringToType :: !String !ParseState -> (!Type, !ParseState) +stringToType name pState + # (id, pState) = stringToIdent name IC_Type pState + | isLowerCaseName name + = nameToTypeVar name pState + = (TA (MakeNewTypeSymbIdent id 0) [], pState) +/* | isUpperCaseName name + = (TA (MakeNewTypeSymbIdent id 0) [], pState) + = nameToTypeVar name pState +*/ +/* +stringToAType :: !String !Annotation !TypeAttribute !ParseState -> (!AType, !ParseState) +stringToAType name annot attr pState + # (id, pState) = stringToIdent name IC_Type pState + | isUpperCaseName name + = ({ at_annotation = annot, at_attribute = attr, at_type = TA (MakeNewTypeSymbIdent id 0) []}, pState) + # (type_var, pState) = nameToTypeVar name pState + = build_attributed_type_var attr annot type_var name pState +where + build_attributed_type_var TA_Anonymous annot type_var type_var_name pState + # (attr_id, pState) = stringToIdent type_var_name IC_TypeAttr pState + = ({ at_annotation = annot, at_attribute = TA_Var (makeAttributeVar attr_id), at_type = type_var }, pState) + build_attributed_type_var attr annot type_var _ pState + = ({ at_annotation = annot, at_attribute = attr, at_type = type_var }, pState) +*/ + +instance want AType +where + want pState = wantAType pState + +instance want Type +where + want pState = wantType pState + +wantType :: !ParseState -> (!Type,!ParseState) +wantType pState + # (succ, atype, pState) = tryAType False AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + | succ&&succ2 + = (type, pState) + // otherwise //~ succ + # (token, pState) = nextToken TypeContext pState + = (type, parseError "type" (Yes token) "type" pState) + +wantAType :: !ParseState -> (!AType,!ParseState) +wantAType pState + # (succ, atype, pState) = tryAType True AN_None TA_None pState + | succ + = (atype, pState) + // otherwise //~ succ + # (token, pState) = nextToken TypeContext pState + = (atype, parseError "atype" (Yes token) "attributed and annotated type" pState) + +tryType :: !ParseState -> (!Bool,!Type,!ParseState) +tryType pState + # (succ, atype, pState) = tryAType False AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + = (succ&&succ2, type, pState) + +tryAType :: !Bool !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryAType tryAA annot attr pState + # (types, pState) = parseList tryBrackAType pState + | isEmpty types + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + # (token, pState) = nextToken TypeContext pState + | token == ArrowToken + = tryFunctionType types annot attr pState + // otherwise + # pState = tokenBack pState + = tryApplicationType types annot attr pState + +tryFunctionType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryFunctionType types annot attr pState + # (rtype, pState) = wantAType pState + = ( True + , make_curry_type annot attr types rtype + , pState + ) +where + make_curry_type annot attr [t1] res_type + = {at_annotation = annot, at_attribute = attr, at_type = t1 --> res_type} + make_curry_type annot attr [t1:tr] res_type + = {at_annotation = annot, at_attribute = attr, at_type = t1 --> make_curry_type AN_None TA_None tr res_type} + make_curry_type _ _ _ _ = abort "make_curry_type: wrong assumption" + +tryApplicationType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryApplicationType [type1:types_rest] annot attr pState + # (annot, pState) = determAnnot annot type1.at_annotation pState + type = type1.at_type + (attr, pState) = determAttr attr type1.at_attribute type pState + | isEmpty types_rest + = ( True + , {at_annotation = annot, at_attribute = attr, at_type = type} + , pState + ) + // otherwise // type application + # (type, pState) = convert_list_of_types type1.at_type types_rest pState + = ( True + , {at_annotation = annot, at_attribute = attr, at_type = type} + , pState + ) +where + convert_list_of_types (TA sym []) types pState + = (TA { sym & type_arity = length types } types, pState) + convert_list_of_types (TV tv) types pState + = (CV tv :@: types, pState) + convert_list_of_types _ types pState + = (TE, parseError "Type" No "ordinary type variable" pState) +tryApplicationType _ annot attr pState + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + +tryBrackType :: !ParseState -> (!Bool, Type, !ParseState) +tryBrackType pState + # (succ, atype, pState) = trySimpleType AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + = (succ&&succ2, type, pState) + +tryBrackAType :: !ParseState -> (!Bool, AType, !ParseState) +tryBrackAType pState + # (_, annot, attr, pState) = optionalAnnotAndAttr pState + = trySimpleType annot attr pState + +trySimpleType :: !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState) +trySimpleType annot attr pState + # (token, pState) = nextToken TypeContext pState + = trySimpleTypeT token annot attr pState + +trySimpleTypeT :: !Token !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState) +trySimpleTypeT (IdentToken id) annot attr pState + | isLowerCaseName id + # (typevar, pState) = nameToTypeVar id pState + (attr, pState) = adjustAttribute attr typevar pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = typevar}, pState) + | otherwise // | isUpperCaseName id || isFunnyIdName id + # (type, pState) = stringToType id pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState) +trySimpleTypeT SquareOpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == SquareCloseToken + # (list_symbol, pState) = makeListTypeSymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState) + # (type, pState) = wantAType (tokenBack pState) + (token, pState) = nextToken TypeContext pState + | token == SquareCloseToken + # (list_symbol, pState) = makeListTypeSymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol [type]}, pState) + // otherwise // token <> SquareCloseToken + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState) +trySimpleTypeT OpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (tup_arity, pState) = determine_arity_of_tuple 2 pState + (tuple_symbol, pState) = makeTupleTypeSymbol tup_arity 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol []}, pState) + // otherwise // token <> CommaToken + # (atype, pState) = wantAType (tokenBack pState) + (token, pState) = nextToken TypeContext pState + | token == CloseToken + # (annot, pState) = determAnnot annot atype.at_annotation pState + type = atype.at_type + (attr, pState) = determAttr attr atype.at_attribute type pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState) + | token == CommaToken // TupleType + # (atypes, pState) = wantSequence CommaToken TypeContext pState + pState = wantToken TypeContext "tuple type" CloseToken pState + atypes = [atype:atypes] + arity = length atypes + (tuple_symbol, pState) = makeTupleTypeSymbol arity arity pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol atypes}, pState) + // otherwise // token <> CloseToken && token <> CommaToken + = (False, atype, parseError "Simple type" (Yes token) "')' or ','" pState) +where + determine_arity_of_tuple :: !Int !ParseState -> (!Int, !ParseState) + determine_arity_of_tuple arity pState + # (token, pState) = nextToken TypeContext pState + | CommaToken == token + = determine_arity_of_tuple (inc arity) pState + | CloseToken == token + = (arity, pState) + = (arity, parseError "tuple type" (Yes token) ")" pState) +trySimpleTypeT CurlyOpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeLazyArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + | token == HashToken + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeUnboxedArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + // otherwise // token <> CurlyCloseToken + # (atype, pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "unboxed array type" CurlyCloseToken pState + (array_symbol, pState) = makeUnboxedArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) + | token == ExclamationToken + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeStrictArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + // otherwise // token <> CurlyCloseToken + # (atype,pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "strict array type" CurlyCloseToken pState + (array_symbol, pState) = makeStrictArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) + // otherwise + # (atype,pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "lazy array type" CurlyCloseToken pState + (array_symbol, pState) = makeLazyArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) +trySimpleTypeT StringTypeToken annot attr pState + # (type, pState) = makeStringTypeSymbol pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA type []}, pState) +trySimpleTypeT token annot attr pState + # (bt, pState) = try token pState + = case bt of + Yes bt -> (True , {at_annotation = annot, at_attribute = attr, at_type = TB bt}, pState) + no -> (False, {at_annotation = annot, at_attribute = attr, at_type = TE} , pState) + +instance try BasicType +where + try IntTypeToken pState = (Yes BT_Int , pState) + try CharTypeToken pState = (Yes BT_Char , pState) + try BoolTypeToken pState = (Yes BT_Bool , pState) + try RealTypeToken pState = (Yes BT_Real , pState) + try DynamicTypeToken pState = (Yes BT_Dynamic , pState) + try FileTypeToken pState = (Yes BT_File , pState) + try WorldTypeToken pState = (Yes BT_World , pState) + try _ pState = (No , tokenBack pState) + +determAnnot :: !Annotation !Annotation !ParseState -> (!Annotation, !ParseState) +determAnnot AN_None annot2 pState = (annot2, pState) +determAnnot annot1 AN_None pState = (annot1, pState) +determAnnot annot1 annot2 pState + = (annot1, parseError "simple type" No ("More type annotations, "+toString annot1+" and "+toString annot2+", than") pState) + +determAttr :: !TypeAttribute !TypeAttribute !Type !ParseState -> (!TypeAttribute, !ParseState) +determAttr TA_None attr2 type pState = adjustAttribute attr2 type pState +determAttr attr1 TA_None type pState = adjustAttribute attr1 type pState +determAttr attr1 attr2 type pState + = (attr1, parseError "simple type" No ("More type attributes, "+toString attr1+" and "+toString attr2+", than") pState) + +wantDynamicType :: !*ParseState -> *(!DynamicType,!*ParseState) +wantDynamicType pState + # (type_vars, pState) = optionalQuantifiedVariables UniversalQuantifier pState + (type, pState) = want pState + = ({ dt_uni_vars = type_vars, dt_type = type, dt_global_vars = [] }, pState) + +:: QuantifierKind = UniversalQuantifier | ExistentialQuantifier + +instance == QuantifierKind +where + (==) UniversalQuantifier UniversalQuantifier + = True + (==) ExistentialQuantifier ExistentialQuantifier + = True + (==) _ _ + = False + +instance try QuantifierKind +where + try (IdentToken name) pState + | name == "A" + # (token, pState) = nextToken TypeContext pState + | token == DotToken + = (Yes UniversalQuantifier, pState) + = (No, tokenBack (tokenBack pState)) + | name == "E" + # (token, pState) = nextToken TypeContext pState + | token == DotToken + = (Yes ExistentialQuantifier, pState) + = (No, tokenBack (tokenBack pState)) + try token pState + = (No, tokenBack pState) + +optionalQuantifiedVariables :: !QuantifierKind !*ParseState -> *(![ATypeVar],!*ParseState) +optionalQuantifiedVariables req_quant pState + # (token, pState) = nextToken TypeContext pState + (optional_quantifier, pState) = try token pState + = case optional_quantifier of + Yes off_quant + # (vars, pState) = wantList "quantified variable(s)" try_Attributed_TypeVar pState + | req_quant == off_quant + -> (vars, pState) + -> (vars, parseError "optional quantified variables" No "illegal quantifier" pState) + No + -> ([], pState) +where + try_Attributed_TypeVar :: !ParseState -> (Bool,ATypeVar,ParseState) + try_Attributed_TypeVar pState + # (token, pState) = nextToken TypeContext pState + = case token of + DotToken + # (succ,typevar, pState) = tryTypeVar pState + | succ + # atypevar = {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + _ + # (succ,typevar, pState) = tryTypeVar (tokenBack pState) + | succ + # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + +tryATypeToType :: !AType !ParseState -> (!Bool, !Type, !ParseState) +tryATypeToType atype pState + | atype.at_annotation <> AN_None + = ( False + , atype.at_type + , parseError "simple type" No ("type instead of type annotation "+toString atype.at_annotation) pState + ) + | atype.at_attribute <> TA_None + = ( False + , atype.at_type + , parseError "simple type" No ("type instead of type attribute "+toString atype.at_attribute) pState + ) + // otherwise + = (True, atype.at_type, pState) + +/* + Expressions +*/ +/* +wantMainExp :: !ParseState -> (ParsedExpr, !ParseState) +wantMainExp pState + # (exp, pState) = wantExpression cIsNotAPattern pState + = (exp, wantEndOfFileToken pState) +*/ +cIsAPattern :== True +cIsNotAPattern :== False + +wantExpression :: !Bool !ParseState -> (!ParsedExpr, !ParseState) +wantExpression is_pattern pState + # (token, pState) = nextToken FunctionContext pState + | is_pattern + = wantLhsExpressionT token pState + = wantRhsExpressionT token pState + +wantRhsExpressionT :: !Token !ParseState -> (!ParsedExpr, !ParseState) +wantRhsExpressionT token pState + # (succ, expr, pState) = trySimpleRhsExpressionT token pState + | succ + # (exprs, pState) = parseList trySimpleRhsExpression pState + = (combineExpressions expr exprs, pState) + = (PE_Empty, parseError "RHS expression" (Yes token) "<expression>" pState) + +wantLhsExpressionT :: !Token !ParseState -> (!ParsedExpr, !ParseState) +wantLhsExpressionT token pState + # (succ, expr, pState) = trySimpleLhsExpressionT token pState + | succ + # (exprs, pState) = parseList trySimpleLhsExpression pState + = (combineExpressions expr exprs, pState) + = (PE_Empty, parseError "LHS expression" (Yes token) "<expression>" pState) + +combineExpressions expr [] + = expr +combineExpressions expr exprs + = make_app_exp expr exprs +where + make_app_exp exp [] + = exp + make_app_exp (PE_Bound be=:{ bind_src}) exps + = PE_Bound { be & bind_src = make_app_exp bind_src exps } + make_app_exp exp exprs + = PE_List [exp : exprs] + +trySimpleLhsExpression :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleLhsExpression pState + # (token, pState) = nextToken FunctionContext pState + = trySimpleLhsExpressionT token pState + +trySimpleLhsExpressionT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleLhsExpressionT token pState + # (succ, expr, pState) = trySimpleExpressionT token cIsAPattern pState + | succ + # (token, pState) = nextToken FunctionContext pState + | token == DoubleColonToken + # (dyn_type, pState) = wantDynamicType pState + = (True, PE_DynamicPattern expr dyn_type, pState) + = (True, expr, tokenBack pState) + = (False, PE_Empty, pState) + +trySimpleRhsExpression :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleRhsExpression pState + # (token, pState) = nextToken FunctionContext pState + = trySimpleRhsExpressionT token pState + +trySimpleRhsExpressionT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleRhsExpressionT token pState + # (succ, expr, pState) = trySimpleExpressionT token cIsNotAPattern pState + | succ + # (expr, pState) = extend_expr_with_selectors expr pState + = (True, expr, pState) + = (False, PE_Empty, pState) +where + extend_expr_with_selectors :: !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState) + extend_expr_with_selectors exp pState + # (token, pState) = nextToken FunctionContext pState + | token == DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (PE_Selection cNonUniqueSelection exp selectors, pState) + | token == ExclamationToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (PE_Selection cUniqueSelection exp selectors, pState) + | otherwise + = (exp, tokenBack pState) + +wantSelectors :: Token *ParseState -> *(![ParsedSelection], !*ParseState) +wantSelectors token pState + # (selector, pState) = want_selector token pState + (token, pState) = nextToken FunctionContext pState + | token == DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (selector ++ selectors, pState) + = (selector, tokenBack pState) +where + want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState) + want_selector SquareOpenToken pState + # (array_selectors, pState) = want_array_selectors pState + = (array_selectors, wantToken FunctionContext "array selector" SquareCloseToken pState) + where + want_array_selectors :: !*ParseState -> *(![ParsedSelection], !*ParseState) + want_array_selectors pState + # (index_expr, pState) = wantExpression cIsNotAPattern pState + selector = PS_Array index_expr + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (selectors, pState) = want_array_selectors pState + = ([selector : selectors], pState) + = ([selector], tokenBack pState) + + want_selector (IdentToken name) pState + | isUpperCaseName name + # (field, pState) = want (wantToken FunctionContext "array selector" DotToken pState) + (field_id, pState) = stringToIdent field IC_Selector pState + (type_id, pState) = stringToIdent name IC_Type pState + = ([PS_Record field_id (Yes type_id)], pState) + # (field_id, pState) = stringToIdent name IC_Selector pState + = ([PS_Record field_id No], pState) + want_selector token pState + = ([PS_Erroneous], parseError "simple RHS expression" (Yes token) "<selector>" pState) + +trySimpleExpression :: !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleExpression is_pattern pState + | is_pattern + = trySimpleLhsExpression pState + = trySimpleRhsExpression pState + +trySimpleExpressionT :: !Token !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleExpressionT (IdentToken name) is_pattern pState + | isLowerCaseName name + # (id, pState) = stringToIdent name IC_Expression pState + (token, pState) = nextToken FunctionContext pState + | token == DefinesColonToken + # (succ, expr, pState) = trySimpleExpression is_pattern pState + | succ + = (True, PE_Bound { bind_dst = id, bind_src = expr }, pState) + = (True, PE_Empty, parseError "simple expression" No "expression" pState) + = (True, PE_Ident id, tokenBack pState) +trySimpleExpressionT (IdentToken name) is_pattern pState +// | isUpperCaseName name || ~ is_pattern + # (id, pState) = stringToIdent name IC_Expression pState + = (True, PE_Ident id, pState) +trySimpleExpressionT SquareOpenToken is_pattern pState + # (list_expr, pState) = wantListExp is_pattern pState + = (True, list_expr, pState) +trySimpleExpressionT OpenToken is_pattern pState + # (args=:[exp:exps], pState) = want_expression_list is_pattern pState + pState = wantToken FunctionContext "expression list" CloseToken pState + | isEmpty exps + = case exp of + PE_Ident id + -> (True, PE_List [exp], pState) + _ + -> (True, exp, pState) + // # (token,pState) = nextToken FunctionContext pState // for debugging + // pState = tokenBack pState -->> ("PE_tuple",args,token) + = (True, PE_Tuple args, pState) +where + want_expression_list is_pattern pState + # (expr, pState) = wantExpression is_pattern pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (exprs, pState) = want_expression_list is_pattern pState + = ([expr : exprs], pState) + = ([expr], tokenBack pState) +trySimpleExpressionT CurlyOpenToken is_pattern pState + # (rec_or_aray_exp, pState) = wantRecordOrArrayExp is_pattern pState + = (True, rec_or_aray_exp, pState) +trySimpleExpressionT (IntToken int) is_pattern pState + = (True, PE_Basic (BVI int), pState) +trySimpleExpressionT (StringToken string) is_pattern pState + = (True, PE_Basic (BVS string), pState) +trySimpleExpressionT (BoolToken bool) is_pattern pState + = (True, PE_Basic (BVB bool), pState) +trySimpleExpressionT (CharToken char) is_pattern pState + = (True, PE_Basic (BVC char), pState) +trySimpleExpressionT (RealToken real) is_pattern pState + = (True, PE_Basic (BVR real), pState) +trySimpleExpressionT token is_pattern pState + | is_pattern + | token == WildCardToken + = (True, PE_WildCard, pState) + = (False, PE_Empty, tokenBack pState) + = trySimpleNonLhsExpressionT token pState + +trySimpleNonLhsExpressionT BackSlashToken pState + # (lam_ident, pState) = internalIdent "\\" pState + (lam_args, pState) = wantList "arguments" trySimpleLhsExpression pState + // pState = wantToken FunctionContext "lambda expression" ArrowToken pState + pState = want_lambda_sep pState + (exp, pState) = wantExpression cIsNotAPattern pState + = (True, PE_Lambda lam_ident lam_args exp, pState) + where + want_lambda_sep pState + # (token, pState) = nextToken FunctionContext pState + = case token of + ArrowToken -> pState + EqualToken -> pState + DotToken -> pState + _ -> parseError "lambda expression" (Yes token) "-> or =" (tokenBack pState) +//trySimpleNonLhsExpressionT (LetToken strict) pState +trySimpleNonLhsExpressionT (LetToken strict=:False) pState // let! is not supported in Clean 2.0 + # (let_binds, pState) = wantLocals pState + pState = wantToken FunctionContext "let expression" InToken pState + (let_expr, pState) = wantExpression cIsNotAPattern pState + = (True, PE_Let strict let_binds let_expr, pState) +trySimpleNonLhsExpressionT WildCardToken pState + = (True, PE_WildCard, pState) +trySimpleNonLhsExpressionT CaseToken pState + # (case_exp, pState) = wantCaseExp pState + = (True, case_exp, pState) +trySimpleNonLhsExpressionT IfToken pState + # (if_ident, pState) = internalIdent "_if" pState + (cond_exp, pState) = want_simple_expression "condition of if" pState + (then_exp, pState) = want_simple_expression "then-part of if" pState + (else_exp, pState) = want_simple_expression "else-part of if" pState + = (True, PE_If if_ident cond_exp then_exp else_exp, pState) +where + want_simple_expression error pState + # (succ, expr, pState) = trySimpleRhsExpression pState + | succ + = (expr, pState) + = (PE_Empty, parseError error No "<expression>" pState) +trySimpleNonLhsExpressionT DynamicToken pState + # (dyn_expr, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + | token == DoubleColonToken + # (dyn_type, pState) = wantDynamicType pState + = (True, PE_Dynamic dyn_expr (Yes dyn_type), pState) + = (True, PE_Dynamic dyn_expr No, tokenBack pState) +trySimpleNonLhsExpressionT token pState + = (False, PE_Empty, tokenBack pState) + +wantListExp :: !Bool !ParseState -> (ParsedExpr, !ParseState) +wantListExp is_pattern pState + # (token, pState) = nextToken FunctionContext pState + = case token of + SquareCloseToken + -> makeNilExpression pState + _ -> want_LGraphExpr token [] pState +where + want_list acc pState + # (token, pState) = nextToken FunctionContext pState + = case token of + SquareCloseToken + # (nil_expr, pState) = makeNilExpression pState + -> gen_cons_nodes acc nil_expr pState + CommaToken + # (token, pState) = nextToken FunctionContext pState + -> want_LGraphExpr token acc pState + ColonToken + # (token, pState) = nextToken FunctionContext pState + (exp, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "list" SquareCloseToken pState + -> gen_cons_nodes acc exp pState + DotDotToken + | length acc > 2 || isEmpty acc + # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list expression" No "one or two expressions before .." pState + -> gen_cons_nodes acc nil_expr pState + # (token, pState) = nextToken FunctionContext pState + -> case token of + SquareCloseToken + -> case acc of + [e] -> (PE_Sequ (SQ_From e), pState) + [e2,e1] + -> (PE_Sequ (SQ_FromThen e1 e2), pState) + _ -> abort "Error 1 in WantListExp" + _ # (exp, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "dot dot expression" SquareCloseToken pState + -> case acc of + [e] -> (PE_Sequ (SQ_FromTo e exp), pState) + [e2,e1] + -> (PE_Sequ (SQ_FromThenTo e1 e2 exp), pState) + _ -> abort "Error 2 in WantListExp" + DoubleBackSlashToken + | length acc == 1 + -> wantComprehension cIsListGenerator (acc!!0) pState + // otherwise // length acc <> 1 + # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list comprehension" No "one expressions before \\\\" pState + -> gen_cons_nodes acc nil_expr pState + _ # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list" (Yes token) "list element separator" pState + -> gen_cons_nodes acc nil_expr pState + + want_LGraphExpr token acc pState + = case token of + CharListToken chars + -> want_list (add_chars (fromString chars) acc) pState + with + add_chars [] acc = acc + add_chars [c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'',c,'\''])): acc] + _ # (exp, pState) = (if is_pattern (wantLhsExpressionT token) (wantRhsExpressionT token)) pState + -> want_list [exp: acc] pState + + gen_cons_nodes [] exp pState + = (exp, pState) + gen_cons_nodes [e:r] exp pState + # (exp, pState) = makeConsExpression e exp pState + = gen_cons_nodes r exp pState + +/** + (List and Array) Comprehensions +**/ + +wantComprehension :: !GeneratorKind !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState) +wantComprehension gen_kind exp pState + # (qualifiers, pState) = wantQualifiers 0 0 pState + | gen_kind == cIsListGenerator + = (PE_Compr cIsListGenerator exp qualifiers, wantToken FunctionContext "list comprehension" SquareCloseToken pState) + = (PE_Compr cIsArrayGenerator exp qualifiers, wantToken FunctionContext "array comprehension" CurlyCloseToken pState) + +wantQualifiers :: !Int !Int !ParseState -> (![Qualifier], !ParseState) +wantQualifiers nr_of_quals nr_of_gens pState + # (qual, nr_of_gens, pState) = want_qualifier nr_of_quals nr_of_gens pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (quals, pState) = wantQualifiers (inc nr_of_quals) nr_of_gens pState + = ([qual : quals], pState) + = ([qual], tokenBack pState) +where + + want_qualifier :: !Int !Int !ParseState -> (!Qualifier, !Int, !ParseState) + want_qualifier qual_nr gen_nr pState + # (lhs_expr, pState) = wantExpression cIsAPattern pState + (token, pState) = nextToken FunctionContext pState + | token == LeftArrowToken + = want_generators cIsListGenerator qual_nr gen_nr lhs_expr pState + | token == LeftArrowColonToken + = want_generators cIsArrayGenerator qual_nr gen_nr lhs_expr pState + = ({qual_generators = [], qual_filter = No, qual_fun_id = { id_name = "", id_info = nilPtr}}, gen_nr, + parseError "comprehension: qualifier" (Yes token) "qualifier(s)" pState) + + want_generators :: !GeneratorKind !Int !Int !ParsedExpr !ParseState -> (!Qualifier, !Int, !ParseState) + want_generators gen_kind qual_nr gen_nr pattern_exp pState + # (gen_expr, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + (gen_var, pState) = stringToIdent ("tl" +++ toString gen_nr) IC_Expression pState + generator = { gen_kind = gen_kind, gen_expr = gen_expr, gen_pattern = pattern_exp, gen_var = gen_var } + | token == BarToken + # (filter_expr, pState) = wantExpression cIsNotAPattern pState + (qual_fun_id, pState) = stringToIdent ("_compr" +++ toString qual_nr) IC_Expression pState + = ({qual_generators = [generator], qual_filter = Yes filter_expr, qual_fun_id = qual_fun_id }, inc gen_nr, pState) + | token == AndToken + # (qualifier, gen_nr, pState) = want_qualifier qual_nr (inc gen_nr) pState + = ({qualifier & qual_generators = [ generator : qualifier.qual_generators] }, gen_nr, pState) + # (qual_fun_id, pState) = stringToIdent ("_compr" +++ toString qual_nr) IC_Expression pState + = ({qual_generators = [generator], qual_filter = No, qual_fun_id = qual_fun_id}, inc gen_nr, tokenBack pState) + +/** + Case Expressions +**/ + +wantCaseExp :: !ParseState -> (ParsedExpr, !ParseState) +wantCaseExp pState + # (case_ident, pState) = internalIdent "_c" pState + (case_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantToken FunctionContext "case expression" OfToken pState + pState = wantBeginGroup "case" pState + (case_alts, pState) = parseList tryCaseAlt pState + (found, alt, pState) = tryLastCaseAlt pState + | found + = (PE_Case case_ident case_exp (case_alts++[alt]), wantEndCase pState) + = (PE_Case case_ident case_exp case_alts, wantEndCase pState) +where + tryCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState) + tryCaseAlt pState + # (succ, pattern, pState) = try_pattern pState + | succ + # (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = pattern, calt_rhs = rhs }, pState) // -->> ("case alt", pattern) + // otherwise // ~ succ + = (False, abort "no case alt", pState) + + tryLastCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState) + tryLastCaseAlt pState + # (token, pState) = nextToken FunctionContext pState + | caseSeperator token + # pState = tokenBack pState + (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") + | token == OtherwiseToken + # (token, pState) = nextToken FunctionContext pState + pState = tokenBack pState + | caseSeperator token + # (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") + = (False, abort "no case alt", pState) + = (False, abort "no case alt", tokenBack pState) + + caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.x case expressions + + try_pattern :: !ParseState -> (!Bool, ParsedExpr, !ParseState) + try_pattern pState + # (succ, expr, pState) = trySimpleLhsExpression pState + | succ + # (succ, expr2, pState) = trySimpleLhsExpression pState + | succ + # (exprs, pState) = parseList trySimpleLhsExpression pState + = (True, PE_List [expr,expr2 : exprs], pState) + = (True, expr, pState) + = (False, abort "no expression", pState) + +:: NestedUpdate = + { nu_selectors :: ![ParsedSelection] + , nu_update_expr :: !ParsedExpr + } +errorIdent :: Ident +errorIdent + = {id_name = "<<error>>", id_info = nilPtr} + +buildNodeDef :: ParsedExpr ParsedExpr -> ParsedDefinition +buildNodeDef lhsExpr rhsExpr + = PD_NodeDef NoPos lhsExpr rhs + where + rhs = + { rhs_alts + = UnGuardedExpr + { ewl_nodes = [] + , ewl_locals = LocalParsedDefs [] + , ewl_expr = rhsExpr + } + , rhs_locals + = LocalParsedDefs [] + } + +/** + Record expressions +**/ + +wantRecordOrArrayExp :: !Bool !ParseState -> (ParsedExpr, !ParseState) +wantRecordOrArrayExp is_pattern pState + # (token, pState) = nextToken FunctionContext pState + | token == CurlyCloseToken + = (PE_ArrayDenot [], pState) + | is_pattern + | token == SquareOpenToken + // # (elems, pState) = want_array_assignments cIsAPattern pState // currently no array selections in pattern PK + // = (PE_Array PE_Empty elems [], wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState) + = (PE_Empty, parseError "array selection" No "No array selection in pattern" pState) + // otherwise // is_pattern && token <> SquareOpenToken + = want_record_pattern token pState + // otherwise // ~ is_pattern + # (opt_type, pState) = try_type_specification token pState + = case opt_type of + Yes _ + -> want_record opt_type pState + _ + # (succ, field, pState) = try_field_assignment token pState + | succ + # (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments cIsNotAPattern token pState + -> (PE_Record PE_Empty No [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState) + | token == CurlyCloseToken + -> (PE_Record PE_Empty No [ field ], pState) + -> (PE_Record PE_Empty No [ field ], parseError "record or array" (Yes token) "}" pState) + # (expr, pState) = wantRhsExpressionT token pState + (token, pState) = nextToken FunctionContext pState + | token == AndToken + # (token, pState) = nextToken FunctionContext pState + -> want_record_or_array_update token expr pState + | token == DoubleBackSlashToken + -> wantComprehension cIsArrayGenerator expr pState + # (elems, pState) = want_array_elems token pState + -> (PE_ArrayDenot [expr : elems], pState) +where + want_array_elems CurlyCloseToken pState + = ([], pState) + want_array_elems CommaToken pState + # (elem, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + (elems, pState) = want_array_elems token pState + = ([elem : elems], pState) + want_array_elems token pState + = ([], parseError "array elements" (Yes token) "<array denotation>" pState) + + want_record_pattern (IdentToken ident) pState + | isUpperCaseName ident + # pState = wantToken FunctionContext "record pattern" BarToken pState + (type_id, pState) = stringToIdent ident IC_Type pState + (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments cIsAPattern token pState + = (PE_Record PE_Empty (Yes type_id) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + want_record_pattern token pState + # (fields, pState) = want_field_assignments cIsAPattern token pState + = (PE_Record PE_Empty No fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + + try_type_specification (IdentToken ident) pState + | isUpperCaseName ident || isFunnyIdName ident + # (token, pState) = nextToken FunctionContext pState + | token == BarToken + # (type_id, pState) = stringToIdent ident IC_Type pState + = (Yes type_id, pState) + = (No, tokenBack pState) + = (No, pState) + try_type_specification _ pState + = (No, pState) + + want_updates :: Token ParsedExpr ParseState -> (ParsedExpr, ParseState) + want_updates token update_expr pState + # (updates, pState) + = parse_updates token update_expr pState + = transform_record_or_array_update update_expr updates pState + where + parse_updates :: Token ParsedExpr ParseState -> ([NestedUpdate], ParseState) + parse_updates token update_expr pState + # (update, pState) = want_update token pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (updates, pState) = parse_updates token update_expr pState + = ([update : updates], pState) + // otherwise + = ([update], tokenBack pState) + + want_update :: Token ParseState -> (NestedUpdate, ParseState) + want_update token pState + # (selectors, pState) = wantSelectors token pState + (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (expr, pState) = wantExpression cIsNotAPattern pState + = ({nu_selectors = selectors, nu_update_expr = expr}, pState) + = ({nu_selectors = selectors, nu_update_expr = PE_Empty}, parseError "field assignment" (Yes token) "=" pState) + + transform_record_or_array_update :: ParsedExpr [NestedUpdate] ParseState -> (ParsedExpr, ParseState) + transform_record_or_array_update expr updates pState + | is_record_update sortedUpdates + = transform_record_update expr groupedUpdates pState + // otherwise + = transform_array_update expr updates pState + where + sortedUpdates + // sort updates by first field name, array updates last + = sortBy smaller_update updates + where + smaller_update :: NestedUpdate NestedUpdate -> Bool + smaller_update a b + = smaller_selector (hd a.nu_selectors) (hd b.nu_selectors) + where + smaller_selector :: ParsedSelection ParsedSelection -> Bool + smaller_selector (PS_Record ident1 _) (PS_Record ident2 _) + = ident1.id_name < ident2.id_name + smaller_selector (PS_Record _ _) _ + = True + smaller_selector _ _ + = False + + groupedUpdates + // group nested updates by first field name + = groupBy equal_update sortedUpdates + where + equal_update :: NestedUpdate NestedUpdate -> Bool + equal_update a b + = equal_selectors a.nu_selectors b.nu_selectors + where + equal_selectors :: [ParsedSelection] [ParsedSelection] -> Bool + equal_selectors [PS_Record ident1 _ : [_]] [PS_Record ident2 _ : [_]] + = ident1.id_name == ident2.id_name + equal_selectors _ _ + = False + + is_record_update [{nu_selectors=[select : _]} : _] + = is_record_select select + is_record_update updates + = False + + is_record_select (PS_Record _ _) + = True + is_record_select _ + = False + + transform_record_update :: ParsedExpr ![[NestedUpdate]] ParseState -> (ParsedExpr, ParseState) + transform_record_update expr groupedUpdates pState + # (assignments, (optionalIdent, pState)) + = mapSt transform_update groupedUpdates (No, pState) + updateExpr + = build_update optionalIdent expr assignments + = (updateExpr, pState) + where + // transform one group of nested updates with the same first field + // for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2}, + // (id is ident to shared expression that's being updated) + transform_update :: [NestedUpdate] (Optional Ident, ParseState) -> (FieldAssignment, (Optional Ident, ParseState)) + transform_update [{nu_selectors=[PS_Record fieldIdent _], nu_update_expr}] state + = ({bind_dst = fieldIdent, bind_src = nu_update_expr}, state) + transform_update updates=:[{nu_selectors=[PS_Record fieldIdent _ : _]} : _] (optionalIdent, pState) + # (shareIdent, pState) + = make_ident optionalIdent pState + select + = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent No] + (update_expr, pState) + = transform_record_or_array_update select (map sub_update updates) pState + = ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent, pState)) + where + make_ident :: (Optional Ident) ParseState -> (Ident, ParseState) + make_ident (Yes ident) pState + = (ident, pState) + make_ident No pState + = internalIdent "s;" pState + + sub_update :: NestedUpdate -> NestedUpdate + sub_update update=:{nu_selectors} + = {update & nu_selectors = tl nu_selectors} + transform_update _ (_, pState) + # pState + = parseError "record or array" No "field assignments mixed with array assignments not" /* expected */ pState + = ({bind_dst = errorIdent, bind_src = PE_Empty}, (No, pState)) + + build_update :: (Optional Ident) ParsedExpr [FieldAssignment] -> ParsedExpr + build_update No expr assignments + = PE_Record expr No assignments + build_update (Yes ident) expr assignments + = PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr]) + (PE_Record (PE_Ident ident) No assignments) + + transform_array_update :: ParsedExpr [NestedUpdate] ParseState -> (ParsedExpr, ParseState) + transform_array_update expr updates pState + // transform {<e> & [i].<...> = e1, ... } to {{<e> & [i1].<...> = e1} & ...} + = foldSt transform_update updates (expr, pState) + where + transform_update :: NestedUpdate (ParsedExpr, ParseState) -> (ParsedExpr, ParseState) + transform_update {nu_selectors, nu_update_expr} (expr1, pState) + = build_update expr1 (split_selectors nu_selectors) nu_update_expr pState + where + // split selectors into final record selectors and initial selectors + // (resulting selectors are reversed) + // for example: [i1].[i2].f.[i3].g.h -> (h.g, [i3].f.[i2].[i1]) + split_selectors selectors + = span is_record_select (reverse selectors) + + build_update :: ParsedExpr ([ParsedSelection], [ParsedSelection]) ParsedExpr ParseState -> (ParsedExpr, ParseState) + build_update expr ([], initial_selectors) update_expr pState + = (PE_Update expr (reverse initial_selectors) update_expr, pState) + // transform {<e> & <...>.[i].f.g. = e1} to + // let + // index_id = i + // (element_id, array_id) = <e>!<...>.[index_id] + // in {array_id & [index_id] = {element_id & f.g = e1}} + build_update expr (record_selectors, [PS_Array index : initial_selectors]) update_expr pState + # (index_id, pState) + = internalIdent "i;" pState + # (element_id, pState) + = internalIdent "e;" pState + # (array_id, pState) + = internalIdent "a;" pState + index_def + = buildNodeDef (PE_Ident index_id) index + select_def + = buildNodeDef + (PE_Tuple [PE_Ident element_id, PE_Ident array_id]) + (PE_Selection cUniqueSelection expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors])) + (updated_element, pState) + = transform_record_update + (PE_Ident element_id) + [[{nu_selectors=(reverse record_selectors), nu_update_expr=update_expr}]] pState + = (PE_Let False + (LocalParsedDefs [index_def, select_def]) + (PE_Update (PE_Ident array_id) (reverse [PS_Array (PE_Ident index_id) : initial_selectors]) updated_element), pState) + + want_field_assignments is_pattern token=:(IdentToken ident) pState + | isLowerCaseName ident + # (field, pState) = want_field_expression is_pattern ident pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments is_pattern token pState + = ([ field : fields ], pState) + = ([ field ], tokenBack pState) + where + want_field_expression is_pattern ident pState + # (field_id, pState) = stringToIdent ident IC_Selector pState + (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (field_expr, pState) = wantExpression is_pattern pState + = ({ bind_src = field_expr, bind_dst = field_id}, pState) + = ({ bind_src = PE_Empty, bind_dst = field_id}, tokenBack pState) + want_field_assignments is_pattern token pState + = ([], parseError "record or array field assignments" (Yes token) "field name" pState) + + try_field_assignment (IdentToken ident) pState + | isLowerCaseName ident + # (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (field_expr, pState) = wantExpression cIsNotAPattern pState + (field_id, pState) = stringToIdent ident IC_Selector pState + = (True, { bind_src = field_expr, bind_dst = field_id}, pState) + = (False, abort "no field", tokenBack pState) + = (False, abort "no field", pState) + try_field_assignment _ pState + = (False, abort "no field", pState) + + want_record type pState + # (token1, pState) = nextToken FunctionContext pState + (token2, pState) = nextToken FunctionContext pState + | isDefinesFieldToken token2 + # (fields, pState) = want_field_assignments cIsNotAPattern token1 (tokenBack pState) + = (PE_Record PE_Empty type fields, wantToken FunctionContext "record" CurlyCloseToken pState) + = want_record_update type token1 (tokenBack pState) + where + want_record_update :: !(Optional Ident) !Token !ParseState -> (!ParsedExpr, !ParseState) + want_record_update type token pState + # (expr, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "record update" AndToken pState + (token, pState) = nextToken FunctionContext pState + = want_update expr token pState + + want_update :: !ParsedExpr !Token !ParseState -> (!ParsedExpr, !ParseState) + want_update exp token pState + # (update_expr, pState) = want_updates token exp pState + // (qualifiers, pState) = try_qualifiers pState // Bug: for RWS + = (update_expr, wantToken FunctionContext "record update" CurlyCloseToken pState) + where + try_qualifiers pState + # (token, pState) = nextToken FunctionContext pState + | token == DoubleBackSlashToken + = wantQualifiers 0 0 pState + = ([], tokenBack pState) + + want_record_or_array_update token expr pState + = want_update expr token pState + + want_array_assignments is_pattern pState + # (assign, pState) = want_array_assignment is_pattern pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # pState = wantToken FunctionContext "array assignments" SquareOpenToken pState + (assigns, pState) = want_array_assignments is_pattern pState + = ([ assign : assigns ], pState) + = ([ assign ], tokenBack pState) + where + want_array_assignment is_pattern pState + # (index_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantToken FunctionContext "array assignment" SquareCloseToken pState + pState = wantToken FunctionContext "array assignment" EqualToken pState + (pattern_exp, pState) = wantExpression is_pattern pState + = ({bind_dst = index_exp, bind_src = pattern_exp}, pState) + +/** + End of definitions +**/ + +skipToEndOfDefinition :: !ParseState -> (!Token, !ParseState) +skipToEndOfDefinition pState + # (token, pState) = nextToken FunctionContext pState + = case token of + NewDefinitionToken -> (token, pState) + EndGroupToken -> (token, pState) + EndOfFileToken -> (token, pState) +// SemicolonToken -> (token, pState) // might be useful in non layout mode. + _ -> skipToEndOfDefinition pState -->> (token,"skipped") + +wantEndOfDefinition :: String !ParseState -> ParseState +wantEndOfDefinition msg pState=:{ps_skipping} + | ps_skipping + # (token, pState) = skipToEndOfDefinition {pState & ps_skipping = False} + // (pos,pState) = getPosition pState // for debugging + = want_end_of_definition token msg pState //-->> ("restart parsing at ",token, pos) + # (token, pState) = nextToken FunctionContext pState + = want_end_of_definition token msg pState +where + want_end_of_definition :: !Token String !ParseState -> ParseState + want_end_of_definition token msg pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + NewDefinitionToken -> pState // -->> "end of definition found due to NewDefinitionToken" + EndOfFileToken -> tokenBack pState // -->> "end of definition found due to EndOfFileToken" + EndGroupToken -> tokenBack pState // -->> "end of definition found due to EndGroupToken" + InToken -> tokenBack pState // -->> "end of definition found due to InToken" + WhereToken -> tokenBack pState // -->> "end of definition found due to WhereToken" + BarToken -> tokenBack pState // -->> "end of definition found due to BarToken" + EqualToken -> tokenBack pState // -->> "end of definition found due to EqualToken" + ArrowToken -> tokenBack pState // -->> "end of definition found due to ArrowToken" + SeqLetToken _ -> tokenBack pState // -->> "end of definition found due to SeqLetToken" + SemicolonToken # (token, pState) = nextToken FunctionContext pState + -> case token of + NewDefinitionToken -> pState // -->> "end of definition found due to SemicolonToken and NewDefinitionToken" + _ -> tokenBack pState// -->> "end of definition found due to SemicolonToken" + token -> wantEndOfDefinition "" (parseError msg (Yes token) "end of definition" pState) + // otherwise // ~ ss_useLayout + = case token of + CurlyCloseToken -> tokenBack pState + SemicolonToken -> pState + EndOfFileToken -> tokenBack pState // -->> "end of definition found due to EndOfFileToken" + token -> wantEndOfDefinition "" (parseError msg (Yes token) "end of definition" pState) + +wantEndRootExpression :: !ParseState -> ParseState +wantEndRootExpression pState=:{ps_skipping} + | ps_skipping + = wantEndOfDefinition "root expression" pState + # (token, pState) = nextToken FunctionContext pState + (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + NewDefinitionToken -> pState + EndOfFileToken -> tokenBack pState + EndGroupToken -> tokenBack pState + EqualToken -> tokenBack pState + ArrowToken -> tokenBack pState + WhereToken -> tokenBack pState + WithToken -> tokenBack pState + BarToken -> tokenBack pState + InToken -> tokenBack pState + CloseToken -> tokenBack pState + (SeqLetToken _) -> tokenBack pState + SemicolonToken # (token, pState) = nextToken FunctionContext pState + -> case token of + NewDefinitionToken -> pState + _ -> tokenBack pState + token -> wantEndOfDefinition "root expression" (parseError "root expression" (Yes token) "end of root expression" pState) + // otherwise // ~ ss_useLayout + = case token of + SemicolonToken -> pState + CurlyCloseToken -> tokenBack pState + EqualToken -> tokenBack pState // Do we really want to allow all of these tokens + ArrowToken -> tokenBack pState + (SeqLetToken _) -> tokenBack pState + WhereToken -> tokenBack pState + WithToken -> tokenBack pState + BarToken -> tokenBack pState + EndOfFileToken -> tokenBack pState + token -> wantEndOfDefinition "root expression" (parseError "root expression" (Yes token) "end of root expression" pState) + +wantEndGroup :: String !ParseState -> ParseState +wantEndGroup msg pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + EndGroupToken -> pState + _ -> parseError msg (Yes token) "end of group with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + = pState + // otherwise // token <> CurlyCloseToken + = parseError msg (Yes token) "end of group without layout, }," pState + +wantEndModule :: !ParseState -> ParseState +wantEndModule pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout && token == EndGroupToken + = pState + = parseError "Definition" (Yes token) "Unexpected token in input: definition" pState + +wantEndNestedGuard :: !Bool !Int !ParseState -> ParseState +wantEndNestedGuard defaultFound offside pState + | ~ defaultFound + = parseError "nested guards" No "sorry, but for the time being there is a default alternative for nested guards" pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + # ({fp_col}, pState) = getPosition pState + | fp_col < offside || (end_Nested_Guard token && fp_col == offside) + = tokenBack pState + // otherwise + = parseError "nested guards" (Yes token) "=, ->, | or # at offside position, or end of function definition" pState + // ~ ss_useLayout + | token == SemicolonToken + = pState + | defaultFound + = tokenBack pState + // otherwise + = parseError "nested guards" (Yes token) "End of nested guards, ;," pState +where + end_Nested_Guard EqualToken = True + end_Nested_Guard BarToken = True + end_Nested_Guard ArrowToken = True + end_Nested_Guard (SeqLetToken _) = True + end_Nested_Guard _ = False + +wantEndLocals :: !ParseState -> ParseState +wantEndLocals pState + # (ss_useLayout, pState) = accScanState UseLayout pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + | ss_useLayout + = case token of + EndGroupToken -> pState + _ -> parseError "local definitions" (Yes token) "end of locals with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + # (token, pState) = nextToken FunctionContext pState + | token == SemicolonToken + = pState + = tokenBack pState + // otherwise // token <> CurlyCloseToken + = parseError "local definitions" (Yes token) "end of locals without layout, }," pState + +wantEndCase :: !ParseState -> ParseState +wantEndCase pState + # (ss_useLayout, pState) = accScanState UseLayout pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + | ss_useLayout + = case token of + EndGroupToken -> pState + CloseToken -> tokenBack (appScanState dropOffsidePosition pState) + SquareCloseToken -> tokenBack (appScanState dropOffsidePosition pState) + SemicolonToken -> tokenBack (appScanState dropOffsidePosition pState) + _ -> parseError "case expression" (Yes token) "end of case with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + = pState + // otherwise // token <> CurlyCloseToken + = parseError "case expression" (Yes token) "end of group without layout, }," pState + +wantBeginGroup :: String !ParseState -> ParseState +wantBeginGroup msg pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = pState + // otherwise // ~ ss_uselayout + # (token, pState) = nextToken FunctionContext pState + = case token of + CurlyOpenToken + -> pState + _ -> parseError msg (Yes token) "begin group without layout, {," pState + +/* + Functions on the parse pState +*/ +/* +instance insertToken ParseState +where + insertToken t c pState = appScanState (insertToken t c) pState + +instance currentToken ParseState +where + currentToken pState = accScanState currentToken pState +*/ +instance replaceToken ParseState +where + replaceToken t pState = appScanState (replaceToken t) pState + +instance tokenBack ParseState +where + tokenBack pState=:{ps_skipping} + | ps_skipping + = pState + = appScanState tokenBack pState + +instance nextToken ParseState +where + nextToken :: !Context !ParseState -> (!Token, !ParseState) + nextToken context pState + | pState.ps_skipping // in error recovery from parse error + = (ErrorToken "Skipping", pState) + = accScanState (nextToken context) pState + +instance getPosition ParseState +where + getPosition pState = accScanState getPosition pState + +parseWarning :: !{# Char} !{# Char} !ParseState -> ParseState +parseWarning act msg pState + | pState.ps_skipping + = pState + | otherwise // not pState.ps_skipping + # (pos,pState) = getPosition pState + (filename,pState=:{ps_error={pea_file,pea_ok}}) = accScanState getFilename pState + pea_file = pea_file + <<< "Parse warning [" + <<< filename <<< "," + <<< pos + <<< (if (size act > 0) ("," + act) "") <<< "]: " + <<< msg + <<< "\n" + = { pState + & ps_error = { pea_file = pea_file, pea_ok = pea_ok } + } + +parseError :: !{# Char} !(Optional Token) !{# Char} !ParseState -> ParseState +parseError act opt_token msg pState + | pState.ps_skipping + = pState + | otherwise // not pState.ps_skipping + # (pos,pState) = getPosition pState + (filename,pState=:{ps_error={pea_file}}) = accScanState getFilename pState + pea_file = pea_file + <<< "Parse error [" + <<< filename <<< "," + <<< pos + <<< (if (size act > 0) ("," + act) "") <<< "]: " + <<< msg + pea_file = case opt_token of + Yes token -> pea_file <<< " expected instead of " <<< token <<< "\n" + No -> pea_file <<< " expected\n" + pState = { pState + & ps_skipping = True + , ps_error = { pea_file = pea_file, pea_ok = False } + } + = case opt_token of + Yes _ -> tokenBack pState + No -> pState + +getFileAndLineNr :: !ParseState -> (!String, !Int, !ParseState) +getFileAndLineNr pState =: {ps_scanState} + # (filename,scanState) = getFilename ps_scanState + ({fp_line},scanState) = getPosition scanState + = (filename, fp_line, {pState & ps_scanState = scanState} ) + +/* + Simple parse functions +*/ + +wantToken :: !Context !{#Char} !Token !ParseState -> ParseState +wantToken context act dem_token pState + # (token, pState) = nextToken context pState + | dem_token == token + = pState // -->> (token,"wanted and consumed") + = parseError act (Yes token) (toString dem_token) pState + +instance want Priority +where + want pState + # (token, pState) = nextToken FunctionContext pState + = case token of + PriorityToken prio + -> (prio, pState) + _ + -> (NoPrio, parseError "Priority" (Yes token) "with" pState) + +instance want {# Char} +where + want pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name -> (name, pState) + _ -> ("", parseError "String" (Yes token) "identifier" pState) + +tryTypeVar :: !ParseState -> (!Bool, TypeVar, !ParseState) +tryTypeVar pState + # (token, pState) = nextToken TypeContext pState + = tryTypeVarT token pState + +tryTypeVarT :: !Token !ParseState -> (!Bool, TypeVar, !ParseState) +tryTypeVarT (IdentToken name) pState + | isUpperCaseName name + = (False, abort "no UC ident", pState) + # (id, pState) = stringToIdent name IC_Type pState + = (True, MakeTypeVar id, pState) +tryTypeVarT token pState + = (False, abort "no type variable", tokenBack pState) + +wantUpperCaseName :: !String !ParseState -> (!String, !ParseState) +wantUpperCaseName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isUpperCaseName name + -> (name, pState) + _ + -> ("dummy uppercase name", parseError string (Yes token) "upper case ident" pState) + +wantLowerCaseName :: !String !ParseState -> (!String, !ParseState) +wantLowerCaseName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isLowerCaseName name + -> (name, pState) + _ + -> ("dummy lowercase name", parseError string (Yes token) "lower case ident" pState) + +wantConstructorName :: !String !ParseState -> (!String, !ParseState) +wantConstructorName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isUpperCaseName name || isFunnyIdName name + -> (name, pState) + _ + -> ("", parseError string (Yes token) "upper case ident" pState) + +/* +isTypeStartToken :: ! Token -> Bool +isTypeStartToken (IdentToken id) = True +isTypeStartToken SquareOpenToken = True +isTypeStartToken CurlyOpenToken = True +isTypeStartToken OpenToken = True +isTypeStartToken IntTypeToken = True +isTypeStartToken CharTypeToken = True +isTypeStartToken BoolTypeToken = True +isTypeStartToken VoidTypeToken = True +isTypeStartToken StringTypeToken = True +isTypeStartToken RealTypeToken = True +isTypeStartToken DynamicTypeToken = True +isTypeStartToken ExclamationToken = True +isTypeStartToken DotToken = True +isTypeStartToken AsteriskToken = True +isTypeStartToken token = False + +isIdentToken :: ! Token -> Bool +isIdentToken (IdentToken id) = True +isIdentToken t = False + +isTypeDefToken :: ! Token -> Bool +isTypeDefToken DoubleColonToken = True +isTypeDefToken token = False + +isDefinesTypeToken :: !Token -> Bool +isDefinesTypeToken EqualToken = True +isDefinesTypeToken ColonDefinesToken = True +isDefinesTypeToken token = False + +isUpperCaseIdent :: ! Token -> Bool +isUpperCaseIdent (IdentToken name) = isUpperCaseName name +isUpperCaseIdent token = False +*/ +isDefinesFieldToken :: ! Token -> Bool +isDefinesFieldToken EqualToken = True +isDefinesFieldToken CurlyCloseToken = True +isDefinesFieldToken CommaToken = True +isDefinesFieldToken token = False + + //---------------// + //--- Tracing ---// +//---------------// + +(-->>) val _ :== val +//(-->>) val message :== val ---> ("Parser",message) |