% $Id: MyOzParser.oz,v 1.12 2012/01/17 11:50:53 leavens Exp leavens $
% AUTHOR: Gary T. Leavens
\insert 'ParserFunctions.oz'
\insert 'OzLexer.oz'
\insert 'Position.oz'
\insert 'AtomStringRep.oz'

declare
[File] = {Module.link ['File.ozf']}

fun {GetParseTree PTL}
   % ENSURES: Result is the parse tree, or parseError, from a parser's output
   case PTL of
      nil then parseError
   [] PT#nil|_ then PT
   [] _#(Tok|_)|_ then
      parseError(coord: {GetPos Tok})
   end
end

fun {ParseFile FileName Reporter}
   % ENSURES: Result is an AST for the file named FileName (or parseError)
   {GetParseTree {ParseOzFile {OzLexer {File.readList FileName} FileName}}}
end

fun {ParseVS VS FileName Reporter}
   % ENSURES: Result is an AST for the file named FileName (or parseError)
   {GetParseTree {ParseOzFile {OzLexer {VirtualString.toString VS} FileName}}}
end

%% Start of the Grammar

% Parsing an Oz file:
ParseOzFile = ParseQueries

ParseQueries =
{P_Alt
 {Using
  {P_Then    % This has to be first, since Queries1 can be empty
   ParseSequence
   ParseQueries1}
  fun {$ S#Qs}
     program(seqQuery(S)|Qs pos: {GetPos S})
  end}
 {Using ParseQueries1 fun {$ Qs} program(Qs) end}
}

ParseQueries1 =
{Using
 {P_Many
  {P_Then
   {P_Check 'declare'}
   {P_Then
    ParseSequence
    {P_Opt
     {P_Then
      {P_Check 'in'}
      {P_Opt ParseSequence skipStmt(pos: unknown 0 0)}}
     nil}}}}
 fun {$ Tr}
    case Tr of
       key('declare' pos:C1)#(S1#(key('in' ...)#S2))|Qs then
       declareInQuery(S1 S2 pos:{MakeLongPos C1 {GetStmtEndPos S2}})|Qs
    [] key('declare' pos:C1)#(S1#nil)|Qs then
       declareQuery(S1 pos:{MakeLongPos C1 {GetStmtEndPos S1}})|Qs
    else Tr
    end
 end}

ParseSequence =
{Using
 {P_Some ParseStatement}
 fun {$ Stmts} seqStmt(Stmts
                       pos:{MakeLongPos
                            {GetStmtStartPos Stmts.1}
                            {GetStmtEndPos {List.last Stmts}}})
 end}

ParseStatement =
{P_Alt ParseSkipStmt
 {P_Alt ParseLocalStmt
  {P_Alt ParseAssignStmt
   {P_Alt ParseIfStmt
    {P_Alt ParseCaseStmt
     {P_Alt ParseApplyStmt
      {P_Alt ParseNamedFunStmt
       ParseThreadStmt}}}}}}}

ParseSkipStmt =
{Using
 {P_Check 'skip'}
 fun {$ key('skip' pos:C)} skipStmt(pos:C) end}

ParseLocalStmt =
{Using
 {P_Then
  {P_Check 'local'}
  {P_Then
   P_VarId
   {P_XThen
    {P_Check 'in'}
    {P_Then
     ParseInStatement
     {P_Check 'end'}}}}}
 fun {$ key('local' pos:C1)#(varId(V pos:CV)#(S#key('end' pos:C2)))}
    localStmt(varId(V pos:CV) S pos:{MakeLongPos C1 C2})
 end}

ParseAssignStmt =
{Using
 {P_Then
  P_VarId
  {P_XThen
   {P_Check '='}
   ParseExpression}}
 fun {$ varId(V pos:C)#Exp}
    unifyStmt(varId(V pos:C) Exp pos:{MakeLongPos C {GetExpEndPos Exp}})
 end}

ParseIfStmt =
{Using
 {P_Then
  {P_Check 'if'}
  {P_Then
   ParseExpression
   {P_XThen
    {P_Check 'then'}
    {P_Then
     ParseInStatement
     {P_XThen
      {P_Check 'else'}
      {P_Then
       ParseInStatement
       {P_Check 'end'}}}}}}}
 fun {$ key('if' pos:C1)#(Exp#(S1#(S2#key('end' pos:C2))))}
    ifStmt(Exp S1 S2 pos:{MakeLongPos C1 C2})
 end}

ParseCaseStmt =
{Using
 {P_Then
  {P_Check 'case'}
  {P_Then
   ParseExpression
   {P_XThen
    {P_Check 'of'}
    {P_Then
     ParsePattern
     {P_XThen
      {P_Check 'then'}
      {P_Then
       ParseInStatement
       {P_XThen
        {P_Check 'else'}
        {P_Then
         ParseInStatement
         {P_Check 'end'}}}}}}}}}
 fun {$ key('case' pos:C1)#(Exp#(Pat#(S1#(S2#key('end' pos:C2)))))}
    caseStmt(Exp Pat S1 S2 pos:{MakeLongPos C1 C2})
 end}

ParseApplyStmt =
{Using
 {P_Then
  {P_Check '{'}
  {P_Then
   ParseExpression
   {P_Then
    {P_Many ParseExpression}
    {P_Check '}'}}}}
 fun {$ key('{' pos:C1)#(E#(Es#key('}' pos:C2))) }
    applyStmt(E Es pos:{MakeLongPos C1 C2})
 end}

ParseNamedFunStmt =
{Using
 {P_Then
  {P_Check 'fun'}
  {P_XThen
   {P_Check '{'}
   {P_Then
    P_VarId
    {P_Then
     ParseFormals
     {P_XThen
      {P_Check '}'}
      {P_Then
       ParseExpression
       {P_Check 'end'}}}}}}}
 fun {$ key('fun' pos:C1)#(varId(Name ...)#(Formals#(Body#key('end' pos:C2))))}
    namedFunStmt(Name Formals Body pos:{MakeLongPos C1 C2})
 end}

ParseThreadStmt =
{Using
 {P_Then
  {P_Check 'thread'}
  {P_Then
   ParseInStatement
   {P_Check 'end'}}}
 fun {$ key('thread' pos:C1)#(S#key('end' pos:C2))}
    threadStmt(S pos:{MakeLongPos C1 C2})
 end}

ParseInStatement =
{Using
 {P_Alt
  ParseSequence
  {P_Then
   ParsePattern
   {P_XThen
    {P_Check '='}
    {P_Then
     ParseExpression
     {P_XThen
      {P_Check 'in'}
      ParseSequence}}}}}
 fun {$ Tr}
    case Tr of
       Pat#(Exp#Body) then
       inStmt(Pat Exp Body pos:{MakeLongPos {GetPatStartPos Pat} {GetStmtEndPos Body}})
    else Tr
    end
 end}

ParseExpression = ParseRelationalExp

ParseRelationalExp =
{Using
 {P_Then
  ParseVBarExp
  {P_Opt
   {P_Then
    ParseRelationOperator
    ParseVBarExp}
   nil}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#(key(Op pos:COp)#E2) then
       local InValue = {Moduleize "Value" Op COp}
       in applyExp(varId(InValue pos:COp) [E1 E2]
                   pos:{MakeLongPos {GetExpStartPos E1} {GetExpEndPos E2}})
       end
    end
 end}
   
% Make a varId token atom from a module name and a field name
fun {Moduleize ModuleString Atom POS}
   varId({StringToAtom {Append ModuleString &.|{AtomStringRep Atom}}} pos:POS)
end

ParseRelationOperator =
{P_Alt {P_Check '=='}
 {P_Alt {P_Check '\\='}
  {P_Alt {P_Check '<'}
   {P_Alt {P_Check '=<'}
    {P_Alt {P_Check '>'}
     {P_Check '>='}}}}}}
      
ParseVBarExp =
{Using
 {P_Then
  ParsePoundExp
  {P_Opt
   {P_Then
    {P_Check '|'}
    ParseVBarExp}
   nil}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#(key('|' pos:CVB)#E2) then
       local C1 = {GetExpPos E1}
          C2 = {GetExpPos E2}
       in recordExp(atomExp('|' pos:CVB)
                    [posFld(E1 pos:C1) posFld(E2 pos:C2)]
                    pos:{MakeLongPos {StartingPos C1} {EndingPos C2}})
       end
    end
 end}

ParsePoundExp =
{Using
 {P_Then
  ParseAdditiveExp
  {P_Many
   {P_Then
    {P_Check '#'}
    ParseAdditiveExp}}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#KEs then
       local C1 = {GetExpPos E1}
          key('#' pos:CVB)#_ = KEs.1
          _#LastE = {List.last KEs}
          C2 = {GetExpPos LastE}
       in recordExp(atomExp('#' pos:CVB)
                    posFld(E1 pos:C1)|{Map KEs fun {$ _#E}
                                              posFld(E pos:{GetExpPos E})
                                           end}
                    pos:{MakeLongPos {StartingPos C1} {EndingPos C2}})
       end
    end
 end}

ParseAdditiveOp = {P_Alt {P_Check '+'} {P_Check '-'}}

ParseAdditiveExp =
{Using
 {P_Then
  ParseMultiplicativeExp
  {P_Many
   {P_Then
    ParseAdditiveOp
    ParseMultiplicativeExp}}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#OEs then
       {FoldL
        OEs
        fun {$ R key(Op pos:C)#E}
           applyExp({Moduleize "Number" Op C}
                    [R E]
                    pos:{MakeLongPos {GetExpStartPos R} {GetExpEndPos E}})
        end
        E1}
    end
 end}

ParseMultiplicativeOp =
{P_Alt {P_Check '*'}
 {P_Alt {P_Check '/'}
  {P_Alt {P_Check 'div'}
   {P_Check 'mod'}}}}

fun {ModuleizeMulOp MulOp}
   case MulOp of
      key('/' pos:C) then {Moduleize "Float" '/' C}
   [] key('*' pos:C) then {Moduleize "Number" '*' C}
   [] key('div' pos:C) then {Moduleize "Int" 'div' C}
   [] key('mod' pos:C) then {Moduleize "Int" 'mod' C}
   end
end

ParseMultiplicativeExp =
{Using
 {P_Then
  ParseNegateExp
  {P_Many
   {P_Then
    ParseMultiplicativeOp
    ParseNegateExp}}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#OEs then
       {FoldL
        OEs
        fun {$ R MulOp#E}
           applyExp({ModuleizeMulOp MulOp}
                    [R E]
                    pos:{MakeLongPos {GetExpStartPos R} {GetExpEndPos E}})
        end
        E1}
    end
 end}


ParseNegateExp =
{Using
 {P_Then
  {P_Many {P_Check '~'}}
  ParseDotExp}
 fun {$ Tr}
    case Tr of
       nil#E then E
    [] Ops#E then
       {FoldR
        Ops
        fun {$ key('~' pos:C) R}
           applyExp({Moduleize "Number" '~' C}
                    [R]
                    pos:{MakeLongPos C {GetExpEndPos R}})
        end
        E}
    end
 end}

ParseDotExp =
{Using
 {P_Then
  ParseTightOpExp
  {P_Many
   {P_Then
    {P_Check '.'}
    ParseTightOpExp}}}
 fun {$ Tr}
    case Tr of
       E#nil then E
    [] E1#OEs then
       {FoldL
        OEs
        fun {$ R key(Op pos:C)#E}
           applyExp({Moduleize "Value" Op C}
                    [R E]
                    pos:{MakeLongPos {GetExpStartPos R} {GetExpEndPos E}})
        end
        E1}
    end
 end}

ParseTightOperator = {P_Check '!!'}

ParseTightOpExp =
{Using
 {P_Then
  {P_Many ParseTightOperator}
  ParsePrimaryExp}
 fun {$ Tr}
    case Tr of
       nil#E then E
    [] OEs#E1 then
       {FoldR
        OEs
        fun {$ key(Op pos:C) E}
           applyExp({Moduleize "Value" Op C}
                    [E]
                    pos:{MakeLongPos C {GetExpEndPos E}})
        end
        E1}
    end
 end}

ParsePrimaryExp =
{P_Alt ParseParenthesizedExp
 {P_Alt ParseVarIdExp
  {P_Alt ParseAtomExp
   {P_Alt ParseBoolExp
    {P_Alt ParseNumExp
     {P_Alt ParseRecordExp
      {P_Alt ParseProcExp
       {P_Alt ParseIfExp
        {P_Alt ParseCaseExp
         {P_Alt ParseApplyExp
          ParseThreadExp}}}}}}}}}}

ParseParenthesizedExp =
{P_XThen
 {P_Check '('}
 {P_ThenX
  ParseExpression
  {P_Check ')'}}}

ParseVarIdExp = P_VarId

ParseAtomExp = {P_Satisfy IsAtomToken}

ParseBoolExp =
{Using
 {P_Alt {P_Check 'true'} {P_Check 'false'}}
 fun {$ Tr}
    case Tr of
       key('true' pos:C) then boolExp(true pos:C)
    [] key('false' pos:C) then boolExp(false pos:C)
    end
 end}

ParseNumExp = P_Number_Token

ParseRecordExp =
{Using
 {P_Alt
  {P_Satisfy IsStrToken}
  {P_Then
   {P_Satisfy IsLabelToken}
   {P_XThen
    {P_Check '('}
    {P_Then
     {P_Many ParseField}
     {P_Check ')'}}}}}
 fun {$ Tr}
    case Tr of
       strTok(Str pos:POS) then  % [[[Doesn't handle escapes?]]]
       {List.foldRInd
        Str
        fun {$ N R}
           NewPos = {AddToPosColumn POS N}
        in
           recordExp(atomExp('|' pos:NewPos)
                     [posFld(intLit({Nth Str N} pos:NewPos))
                      posFld(R pos:NewPos)]
                     pos:NewPos)
        end
        atomExp(nil pos:POS)}
    [] label(L pos:CL)#(Fs#key(')' pos:CEnd)) then
       recordExp(L Fs pos:{MakeLongPos CL CEnd})
    end
 end}

ParseField =
{Using
 {P_Alt
  {P_Then
   ParseFeature
   {P_XThen
    {P_Check ':'}
    ParseExpression}}
  ParseExpression}
 fun {$ Tr}
    case Tr of
       atomExp(FN pos:C)#E then colonFld(atomExp(FN pos:C) E pos:{MakeLongPos C {GetExpEndPos E}})
    [] intLit(I pos:C)#E then colonFld(intLit(I pos:C) E pos:{MakeLongPos C {GetExpEndPos E}})
    [] boolExp(B pos:C)#E then colonFld(boolExp(B pos:C) E pos:{MakeLongPos C {GetExpEndPos E}})
    else posFld(Tr pos:{GetExpPos Tr})
    end
 end}

ParseFeature =
{P_Alt
 ParseAtomExp
 {P_Alt
  {P_Satisfy IsIntToken}
  ParseBoolExp}}


ParseProcExp =
{Using
 {P_Then
  {P_Check 'proc'}
  {P_XThen
   {P_Check '{'}
   {P_XThen
    {P_Check '$'}
    {P_Then
     {P_Many ParsePattern}
     {P_XThen
      {P_Check '}'}
      {P_Then
       ParseSequence
       {P_Check 'end'}}}}}}}
 fun {$ key('proc' pos:C1)#(Pats#(Stmt#(key('end' pos:C2))))}
    procExp(Pats Stmt pos:{MakeLongPos C1 C2})
 end}

ParseIfExp =
{Using
 {P_Then
  {P_Check 'if'}
  {P_Then
   ParseExpression
   {P_XThen
    {P_Check 'then'}
    {P_Then
     ParseExpression
     {P_XThen
      {P_Check 'else'}
      {P_Then
       ParseExpression
       {P_Check 'end'}}}}}}}
 fun {$ key('if' pos:C1)#(TestExp#(E1#(E2#key('end' pos:C2))))}
    ifExp(TestExp E1 E2 pos:{MakeLongPos C1 C2})
 end}

ParseCaseExp =
{Using
 {P_Then
  {P_Check 'case'}
  {P_Then
   ParseExpression
   {P_XThen
    {P_Check 'of'}
    {P_Then
     ParsePattern
     {P_XThen
      {P_Check 'then'}
      {P_Then
       ParseExpression
       {P_XThen
        {P_Check 'else'}
        {P_Then
         ParseExpression
         {P_Check 'end'}}}}}}}}}
 fun {$ key('case' pos:C1)#(Exp#(Pat#(E1#(E2#key('end' pos:C2)))))}
    caseExp(Exp Pat E1 E2 pos:{MakeLongPos C1 C2})
 end}

ParseApplyExp =
{Using
 {P_Then
  {P_Check '{'}
  {P_Then
   ParseExpression
   {P_Then
    {P_Many ParseExpression}
    {P_Check '}'}}}}
 fun {$ key('{' pos:C1)#(E#(Es#key('}' pos:C2))) }
    applyExp(E Es pos:{MakeLongPos C1 C2})
 end}

ParseThreadExp =
{Using
 {P_Then
  {P_Check 'thread'}
  {P_Then
   ParseExpression
   {P_Check 'end'}}}
 fun {$ key('thread' pos:C1)#(E#key('end' pos:C2))}
    threadExp(E pos:{MakeLongPos C1 C2})
 end}

ParsePattern = ParseVBarPat

ParseVBarPat =
{Using
 {P_Then
  ParsePoundPat
  {P_Opt
   {P_Then
    {P_Check '|'}
    ParseVBarPat}
   nil}}
 fun {$ Tr}
    case Tr of
       P#nil then P
    [] P1#(key('|' pos:CVB)#P2) then
       local C1 = {GetPatPos P1}
          C2 = {GetPatPos P2}
       in recordPat(atomExp('|' pos:CVB)
                    [posFld(P1 pos:C1) posFld(P2 pos:C2)]
                    pos:{MakeLongPos {StartingPos C1} {EndingPos C2}})
       end
    end
 end}
 
ParsePoundPat =
{Using
 {P_Then
  ParsePrimitivePat
  {P_Many
   {P_Then
    {P_Check '#'}
    ParsePrimitivePat}}}
 fun {$ Tr}
    case Tr of
       P#nil then P
    [] P1#Ps then
       local C1 = {GetPatPos P1}
          key('#' pos:CVB)#_ = Ps.1
          _#LastP = {List.last Ps}
          C2 = {GetPatPos LastP}
       in recordPat(atomExp('#' pos:CVB)
                    posFld(P1 pos:C1)|{Map Ps fun {$ _#P}
                                             posFld(P pos:{GetPatPos P})
                                          end}
                    pos:{MakeLongPos {StartingPos C1} {EndingPos C2}})
       end
    end
 end}

ParsePrimitivePat =
{P_Alt ParseVarIdPat
  {P_Alt ParseAtomPat
   {P_Alt ParseBoolPat
    {P_Alt ParseParenthesizedPat
     ParseRecordPat}}}}

ParseVarIdPat =
{Using
 P_VarId
 fun {$ varId(V pos:C)}
    varIdPat(V pos:C)
 end}

ParseAtomPat =
{Using
 {P_Satisfy IsAtomToken}
 fun {$ atomExp(A pos:C)}
    atomPat(A pos:C)
 end}

ParseBoolPat =
{Using
 ParseBoolExp
 fun {$ boolExp(B pos:C)}
    boolPat(B pos:C)
 end}

ParseParenthesizedPat =
{P_XThen
 {P_Check '('}
 {P_ThenX
  ParsePattern
  {P_Check ')'}}}

ParseRecordPat =
{Using
 {P_Then
  {P_Satisfy IsLabelToken}
  {P_XThen
   {P_Check '('}
   {P_Then
    {P_Many ParsePatField}
    {P_Check ')'}}}}
 fun {$ label(L pos:CL)#(Fs#key(')' pos:CEnd))}
    recordPat(atomExp(L pos:CL) Fs pos:{MakeLongPos CL CEnd})
 end}

ParsePatField =
{Using
 {P_Alt
  {P_Then
   ParseFeature
   {P_XThen
    {P_Check ':'}
    ParsePattern}}
  ParsePattern}
 fun {$ Tr}
    case Tr of
       atomExp(FN pos:C)#P then colonFld(atomExp(FN pos:C) P pos:{MakeLongPos C {GetPatEndPos P}})
    [] intLit(I pos:C)#P then colonFld(intLit(I pos:C) P pos:{MakeLongPos C {GetPatEndPos P}})
    [] boolExp(B pos:C)#P then colonFld(boolExp(B pos:C) P pos:{MakeLongPos C {GetPatEndPos P}})
    else posFld(Tr pos:{GetPatPos Tr})
    end
 end}

ParseFormals = {P_Many ParsePattern}