-- This source is licensed under the Sunset License v1.0 with Ada.Text_IO, Packrat.Standard, Packrat.Utilities; use Ada.Text_IO; procedure Sentence is Input : String := "i saw a man in the park with a bat"; type Lexer_Labels is (Word, Whitespace); type Parser_Labels is (S, NP, PP, VP, Det, Noun, Verb, Prep); package My_Rat is new Packrat.Standard (Lexer_Labels, Parser_Labels, Character, String); use My_Rat; -- Lexer grammar to group letters into words and get rid of whitespace function Sat_Alpha is new Lexers.Satisfy (Packrat.Utilities.Is_Letter); function Many_Alpha is new Lexers.Many (Sat_Alpha, 1); function Word is new Lexers.Stamp (Word, Many_Alpha); function Sat_Blank is new Lexers.Satisfy (Packrat.Utilities.Is_Whitespace); function Many_Blank is new Lexers.Many (Sat_Blank, 1); function Whitespace is new Lexers.Discard (Whitespace, Many_Blank); package Scanner is new Lexers.Scan_Once ((Word'Access, Whitespace'Access)); -- Parser grammar from page 2 of -- Parser Combinators for Ambiguous Left-Recursive Grammars -- (Richard A. Frost, Rahmatullah Hafiz, Paul Callaghan, 2008) -- s ::= np vp | s pp -- np ::= noun | det noun | np pp -- pp ::= prep np -- vp ::= verb np -- det ::= "a" | "the" -- noun ::= "i" | "man" | "park" | "bat" -- verb ::= "saw" -- prep ::= "in" | "with" function Is_In is new Lexer_Tokens.Is_Value ("in"); function Is_With is new Lexer_Tokens.Is_Value ("with"); function Sat_In is new Parsers.Satisfy (Is_In); function Sat_With is new Parsers.Satisfy (Is_With); function Prep_Choice is new Parsers.Choice_2 (Sat_In, Sat_With); function Prep is new Parsers.Stamp (Prep, Prep_Choice); function Is_Saw is new Lexer_Tokens.Is_Value ("saw"); function Sat_Saw is new Parsers.Satisfy (Is_Saw); function Verb is new Parsers.Stamp (Verb, Sat_Saw); function Is_I is new Lexer_Tokens.Is_Value ("i"); function Is_Man is new Lexer_Tokens.Is_Value ("man"); function Is_Park is new Lexer_Tokens.Is_Value ("park"); function Is_Bat is new Lexer_Tokens.Is_Value ("bat"); function Sat_I is new Parsers.Satisfy (Is_I); function Sat_Man is new Parsers.Satisfy (Is_Man); function Sat_Park is new Parsers.Satisfy (Is_Park); function Sat_Bat is new Parsers.Satisfy (Is_Bat); function Noun_Choice is new Parsers.Choice ((Sat_I'Access, Sat_Man'Access, Sat_Park'Access, Sat_Bat'Access)); function Noun is new Parsers.Stamp (Noun, Noun_Choice); function Is_A is new Lexer_Tokens.Is_Value ("a"); function Is_The is new Lexer_Tokens.Is_Value ("the"); function Sat_A is new Parsers.Satisfy (Is_A); function Sat_The is new Parsers.Satisfy (Is_The); function Det_Choice is new Parsers.Choice_2 (Sat_A, Sat_The); function Det is new Parsers.Stamp (Det, Det_Choice); -- These redirectors are needed to resolve circular references in the instantiations. package NP_Redir is new Parsers.Redirect; package S_Redir is new Parsers.Redirect; function VP_Seq is new Parsers.Sequence_2 (Verb, NP_Redir.Call); function VP is new Parsers.Stamp (VP, VP_Seq); function PP_Seq is new Parsers.Sequence_2 (Prep, NP_Redir.Call); function PP is new Parsers.Stamp (PP, PP_Seq); function NP_Seq_1 is new Parsers.Sequence_2 (Det, Noun); function NP_Seq_2 is new Parsers.Sequence_2 (NP_Redir.Call, PP); function NP_Choice is new Parsers.Choice ((Noun'Access, NP_Seq_1'Access, NP_Seq_2'Access)); function NP is new Parsers.Stamp (NP, NP_Choice); function S_Seq_1 is new Parsers.Sequence_2 (NP, VP); function S_Seq_2 is new Parsers.Sequence_2 (S_Redir.Call, PP); function S_Choice is new Parsers.Choice_2 (S_Seq_1, S_Seq_2); function S is new Parsers.Stamp (S, S_Choice); package Parser is new Parsers.Parse_Once (S); Lexed_Tokens : Lexer_Result := Scanner.Scan (Input); Result_Graph : Parser_Result; begin -- Very important! -- If these aren't set before calling the parser, an exception will be raised. NP_Redir.Set (NP'Access); S_Redir.Set (S'Access); Result_Graph := Parser.Parse (Lexed_Tokens); Put_Line ("Input:"); Put_Line (Input); New_Line; Put_Line ("Lexer token output:"); for T of Lexed_Tokens loop Put (Lexer_Tokens.Debug_String (T)); end loop; New_Line; Put_Line ("Parser graph output:"); Put_Line (Parse_Graphs.Debug_String (Result_Graph)); New_Line; Put_Line ("Root tokens:"); for T of Result_Graph.Root_Elements loop Put (Parser_Tokens.Debug_String (T)); end loop; end Sentence;