% GENPAR.ML %

% This file contains the main body of code for the Generic Parser %


let { { type IdLxcl <=> unit with _ = () }

ins type {

    Lxcl = IdLxcl EnumObj

and LxclType = IdLxcl EnumType } }

enc {

    EqLxcl( lxcl1: Lxcl, lxcl2: Lxcl ) = EqEnumObj(lxcl1,lxcl2)

and OrdLxcl = OrdEnumObj

and NthLxcl = NthEnumObj

and DeclareLxcls = DeclareEnumType

and NumOfLxcls = CardinalityOfEnumType

and LxclOfName = EnumObjOfName

and AppLxcls  = AppEnumObj

and MapLxclsToList = MapEnumObjToList

and NameOfLxcl = NameOfEnumObj

and { PrnameOfLxcl = PrnameOfEnumObj

enc { PrLxcl lxclty = GenPrPrname(PrnameOfLxcl lxclty)

and PrALxcl lxclty = GenPrAPrname(PrnameOfLxcl lxclty)

and PrLxclList lxclty =
    GenPrPrnameList(PrnameOfLxcl lxclty) }
} };




% Sets of Lexical Classes %

let {

    type rec LxclsetClass <=> (|
       lxclType: LxclType;
       setAsArrayClass: Lxcl SetAsArrayClass;
       dict: Lxclset Dictionary |)

    and Lxclset <=> (|
       array: Lxcl SetAsArray;
       name: string;
       prname: string;
       lxclsetClass: LxclsetClass |)

} with {

    PrLxclset(lxclset: Lxclset): unit = PrName(repLxclset(lxclset).prname)

enc PrALxclset( lxclset: Lxclset ): unit = PrAName(repLxclset(lxclset).prname)

enc DeclLxclset
    (lxclsetClass: LxclsetClass)
    ( name: Name, prname: Name, lxclList: Lxcl list )
: Lxclset
=
    let (|lxclType;setAsArrayClass;dict|) = repLxclsetClass(lxclsetClass)
    enc array = SetAsArrayOfList setAsArrayClass lxclList
    enc lxclset = absLxclset(| array; name; prname; lxclsetClass |)
    enc () = AddToDictionary(dict,name,lxclset)
    in lxclset

enc {   AddBasicLxclset (lxclsetClass: LxclsetClass) (lxcl: Lxcl) : Lxclset =
            let (|lxclType;setAsArrayClass;dict|) =
                repLxclsetClass(lxclsetClass)
            enc name = NameOfLxcl lxclType lxcl
            enc prname = PrnameOfLxcl lxclType lxcl
            in DeclLxclset(lxclsetClass)(name,prname,[lxcl])

    ins NewLxclsetClass(lxclType: LxclType): LxclsetClass # (Lxclset list) =
            let arraySize = NumOfLxcls(lxclType)
            enc ordFn = OrdLxcl
            enc nthFn = NthLxcl
            enc setAsArrayClass = NewSetAsArrayClass(arraySize,ordFn,nthFn)
            enc dict = NewDictionary(
                16,
                (\_. failwith `Undeclared Lexical Class Set Name`),
                (\_. failwith `Duplicated Lexical Class Set Name`),
                outtok,
                PrLxclset )
            enc lxclsetClass = absLxclsetClass(|lxclType;setAsArrayClass;dict|)
            in (
                lxclsetClass,
                MapLxclsToList lxclType (AddBasicLxclset lxclsetClass) ) }

enc DeclLxclsetUsingNames
        (lxclsetClass: LxclsetClass)
        ( name: Name, prname: Name, lxclNameList: Name list )
    : Lxclset
    =
        let (|lxclType;setAsArrayClass;dict|) = repLxclsetClass(lxclsetClass)
        enc lxclList = map (LxclOfName lxclType) lxclNameList
        in DeclLxclset lxclsetClass (name,prname,lxclList)

enc LxclsetOfName (lxclsetClass: LxclsetClass) (name: string) : Lxclset =
        FetchFromDictionary( repLxclsetClass(lxclsetClass).dict, name )

enc {   MemberLxclsetRep = MemberSetAsArray(OrdLxcl)

    ins MemberLxclset( lxcl: Lxcl, lxclset: Lxclset ): bool =
        MemberLxclsetRep( lxcl, repLxclset(lxclset).array ) }

enc AppLxclset (f: Lxcl -> unit) (lxclset: Lxclset) : unit =
    AppSetAsArray f (repLxclset(lxclset).array)

};




% Generic Lex Stream package %

let type ('lexMode,'lex)LexStream <=> (|
    bufStream: BufStream;
    readLex: 'lexMode -> 'lex |)

with { NewLexStream(|
    bufStream %: BufStream%;
    readLexFromBufStream %: BufStream -> 'lexMode -> 'lex% |)
=
    absLexStream(| bufStream; readLex = readLexFromBufStream bufStream |)

and ReadLexStream lexStream %lexMode% =
    repLexStream(lexStream).readLex %lexMode%

and BreakLexStream(lexStream) =
    BreakBufStream(repLexStream(lexStream).bufStream)

and AbortToInteractiveLexStream(lexStream) =
    AbortToInteractiveBufStream(repLexStream(lexStream).bufStream)

and CloseLexStream(lexStream) =
    CloseBufStream(repLexStream(lexStream).bufStream) };




% "General purpose" Memory Stream package %

let type {
    ('m,'a)Memstr <=> (|
        genFn : 'm -> 'a;
        backtrackFailTok : string;
        memList : 'a list ref;
        useLast : bool ref;
        numRead : int ref |)
and
    MemstrPosn <=> int }
with
    NewMemstr(genFn,backtrackFailTok) = absMemstr(|
        genFn; backtrackFailTok;
        memList= ref nil; useLast= ref false; numRead= ref 0 |)
and
    NextMemstr(m,s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in
            if !useLast then hd(!memList)
            else
                let x = genFn(m) in (
                    memList := x :: !memList;
                    useLast := true;
                    x )
and
    ReadMemstr(m,s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in (
            numRead := !numRead + 1;
            if !useLast then ( useLast := false; hd(!memList) )
            else let x = genFn(m) in ( memList := x :: !memList; x ) )
and
    SkipGotMemstr(s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in (
            numRead := !numRead + 1;
            useLast := false )
and
    MemstrPosn(s) = absMemstrPosn(!(repMemstr s).numRead)
and
    BacktrackMemstr(p,s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in
            if repMemstrPosn p = !numRead then () % OK? %
            else if repMemstrPosn p = !numRead - 1 then
                if !useLast then failwith backtrackFailTok
                else ( numRead := !numRead - 1; useLast := true )
            else failwith backtrackFailTok
and {
    BreakMemstr(s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in (
            numRead := 0;
            memList := if !useLast then [ hd(!memList) ] else nil )
enc
    ClearMemstr(s) =
        let (| genFn; backtrackFailTok; memList; useLast; numRead |) =
            repMemstr s
        in (
            memList := nil;
            useLast := false;
            numRead := 0 )
} and
    MemstrList(s) = !(repMemstr s).memList;




let indent'step = 4;


let rec type 'a Tree <=> [| atom: 'a; list: 'a Tree list |]

with {
    {rec HasSublist l =
        if null l then false
        else if repTree(hd l) is list then true
        else HasSublist(tl l) }

    ins {rec PrTokTree i x = (
        if i>=0 then (newline(1); space(i)) else space(1);
        let x = repTree x in
            if x is atom then outtok (x as atom)
            else
                let l = x as list in (
                    outtok(`[`);
                    if HasSublist l then (
                        PrTokTree (~1) (hd l);
                        Do(map (PrTokTree (i + indent'step)) (tl l)) )
                    else
                        Do(map (PrTokTree (~1)) l);
                    outtok(` ]`) ) )} }

and ConsAtom x = absTree [| atom= x |]

and ConsList l = absTree [| list= l |]

and AsAtom l = repTree l as atom

and AsList l = repTree l as list

and { {
        rec BuildTokTreeSub xl =
            if null xl then failwith `BuildTokTree`
            else
                let x :: xl = xl in
                    if x=`[` then
                        let yl, xl = BuildTokTreeSubList(nil,xl) in
                            ConsList yl, xl
                    else ConsAtom x, xl

        and BuildTokTreeSubList(yl,xl) =
            if null xl then failwith `BuildTokTree`
            else if hd xl = `]` then yl, tl xl
            else
                let y, xl = BuildTokTreeSub xl in
                    BuildTokTreeSubList(yl @ [y], xl) }

    ins { BuildTokTree xl =
            let y, xl = BuildTokTreeSub xl in
                if null xl then y else failwith `BuildTokTree`

        and rec BuildTokTreeList xl =
            if null xl then nil
            else
                let y, xl = BuildTokTreeSub xl in
                    y :: BuildTokTreeList(xl) } };


let type Word = string;

let type BindingPower = int;

let { { type IdSycl <=> unit with _ = () }

ins type {

    Sycl = IdSycl EnumObj

and SyclType = IdSycl EnumType } }

enc { 
    EqSycl( clty1: Sycl, clty2: Sycl ) = EqEnumObj(clty1,clty2)

and OrdSycl = OrdEnumObj

and DeclareSycls = DeclareEnumType

and NumOfSycls = CardinalityOfEnumType

and SyclOfName = EnumObjOfName

and { PrnameOfSycl = PrnameOfEnumObj

enc { PrSycl cltyty = GenPrPrname(PrnameOfSycl cltyty)

and PrASycl cltyty = GenPrAPrname(PrnameOfSycl cltyty)

and PrSyclList cltyty =
    GenPrPrnameList(PrnameOfSycl cltyty) }
} };


let rec type Form <=> [|
    word: Word;
    class: Lxclset;
    clz: (| bindingPower: BindingPower; targetSycl: Sycl |);
    clzalt: (| bindingPower: BindingPower; targetSycls: Sycl list |);
    opt: Form list;
    rpt: (| minRpt: int; formSeq: Form list |);
    rptsep: (| minRpt: int; sep: Form; formSeq: Form list |);
    alt: Form list list |];

let FormWord(t) = absForm[|word=t|];

let FormClass(s: Lxclset) = absForm[|class=s|];

let FormClz(bp,tt) = absForm[|clz=(|
    bindingPower=bp; targetSycl=tt |)|];

let FormClzalt(bp,ttl) = absForm[|clzalt=(|
    bindingPower=bp; targetSycls=ttl |)|];

let FormOpt(fl) = absForm[|opt=fl|];

let FormRpt(m,fl) = absForm[|rpt=(| minRpt=m; formSeq=fl |)|];

let FormRptsep(m,s,fl) = absForm[|rptsep=(|
    minRpt=m; sep=s; formSeq=fl |)|];

let FormAlt(fll) = absForm[|alt=fll|];

let rec MakeForm(lxclsetClass,cltyty,l) =
    (   let l = AsList l
        ins k, l = AsAtom (hd l), tl l
        in
            if k = `word` then
                FormWord(AsAtom(hd l))
            else if k = `class` then
                let [x] = l in
                    FormClass(LxclsetOfName lxclsetClass (AsAtom(x)))
            else if k = `clause` then
                let bp = intoftok(AsAtom(hd l)) in
                    if length(l) = 2 then
                        FormClz( bp, SyclOfName cltyty (AsAtom(hd(tl l))) )
                    else
                        FormClzalt(
                            bp,
                            map (\a. SyclOfName cltyty (AsAtom a)) (tl l) )
            else if k = `opt` then
                FormOpt(MakeFormSeq(lxclsetClass,cltyty,l))
            else if k = `rpt` then
                FormRpt(
                    intoftok(AsAtom(hd l)),
                    MakeFormSeq(lxclsetClass,cltyty,tl l) )
            else if k = `rptsep` then
                FormRptsep(
                    intoftok(AsAtom(hd l)),
                    MakeForm(lxclsetClass,cltyty,hd(tl l)),
                    MakeFormSeq(lxclsetClass,cltyty,tl(tl l)) )
            else if k = `alt` then
                FormAlt( map (\l.MakeFormSeq(lxclsetClass,cltyty,AsList l)) l )
            else fail )
    ? failwith `MakeForm`

and MakeFormSeq(lxclsetClass,cltyty,l) =
    map (\l.MakeForm(lxclsetClass,cltyty,l)) l;



let type ('phr,'clz,'synStream)Irule <=> [|
    normalWord : (|
        resultSycl : Sycl;
        formSeq : Form list;
        semfn : 'phr list -> 'clz  |);
    normalClass : (|
        resultSycl : Sycl;
        formSeq : Form list;
        semfn : 'phr list -> 'clz  |);
    functional : 'synStream -> Sycl -> 'clz # Sycl |];

let type ('phr,'clz)Mrule <=> (|
    leftBindingPower : BindingPower;
    resultSycl : Sycl;
    formSeq : Form list;
    semfn : 'phr list -> 'clz  |);

let type ('phr,'clz,'synStream)IruleTable <=>
    ('phr,'clz,'synStream)Irule Opt array Opt ref;

let type ('phr,'clz)MruleTable <=>
    ('phr,'clz)Mrule Opt array Opt array Opt ref;

let type ('lex,'phr,'clz,'info,'synStream)Lex' <=> (|
    Lex : 'lex;
    WordInfo : (|
        IruleTable : ('phr,'clz,'synStream)IruleTable;
        MruleTable : ('phr,'clz)MruleTable;
        Reserved : bool ref;
        OtherInfo : 'info |) Opt |);

let rec type ('lex,'clz,'info,'synStream)Phr <=> [|
    word   :  ('lex,('lex,'clz,'info,'synStream)Phr,'clz,'info,'synStream)Lex';
    class  :  ('lex,('lex,'clz,'info,'synStream)Phr,'clz,'info,'synStream)Lex';
    clz    :  'clz;
    opt    :  [| success: ('lex,'clz,'info,'synStream)Phr list; failure |];
    rpt    :  ('lex,'clz,'info,'synStream)Phr list list;
    rptsep :  ('lex,'clz,'info,'synStream)Phr list list;
    alt : (| altNum: int; phrSeq: ('lex,'clz,'info,'synStream)Phr list |) |];

let type { ('lex,'clz,'info,'synStream)Irule =
    (('lex,'clz,'info,'synStream)Phr,'clz,'synStream)Irule
and ('lex,'clz,'info,'synStream)Mrule =
    (('lex,'clz,'info,'synStream)Phr,'clz)Mrule
and ('lex,'clz,'info,'synStream)IruleTable =
    (('lex,'clz,'info,'synStream)Phr,'clz,'synStream)IruleTable
and ('lex,'clz,'info,'synStream)MruleTable =
    (('lex,'clz,'info,'synStream)Phr,'clz)MruleTable
and ('lex,'clz,'info,'synStream)Lex' =
    ('lex,('lex,'clz,'info,'synStream)Phr,'clz,'info,'synStream)Lex' };

let UnknownLex'(lex) = absLex'(| Lex = lex; WordInfo = None |)
and LexOfLex'(lex') = repLex'(lex').Lex
and IsKnownLex'(lex') = Exists(repLex'(lex').WordInfo)
and { KnownOfLex'(lex') = The(repLex'(lex').WordInfo)
enc { IruleTableOfKnownLex'(lex') = KnownOfLex'(lex').IruleTable
and MruleTableOfKnownLex'(lex') = KnownOfLex'(lex').MruleTable } };


let NormalWordIrule(rt,fl,fn) = absIrule[| normalWord = (|
    resultSycl=rt; formSeq=fl; semfn=fn |) |];

let NormalClassIrule(rt,fl,fn) = absIrule[| normalClass = (|
    resultSycl=rt; formSeq=fl; semfn=fn |) |];


let Mrule(lbp,rty,fl,fn) = absMrule(|
    leftBindingPower=lbp; resultSycl=rty; formSeq=fl; semfn=fn |);


let PhrWord(lex') = absPhr[|word=lex'|]
and PhrClass(lex') = absPhr[|class=lex'|]
and PhrClz(cl) = absPhr[|clz=cl|]
and PhrOpt(phrlo) = absPhr[|opt=phrlo|]
and PhrRpt(phrll) = absPhr[|rpt=phrll|]
and PhrRptsep(phrll) = absPhr[|rptsep=phrll|]
and PhrAlt(r) = absPhr[|alt=r|];



let NthRepPhr(phrl,n) = repPhr(nth(phrl,n));

let NthWordLex'(phrl,n) = NthRepPhr(phrl,n) as word;

let NthClassLex'(phrl,n) = NthRepPhr(phrl,n) as class;

let NthClassLex(phrl,n) = LexOfLex'(NthClassLex'(phrl,n));

let NthClz(phrl,n) = NthRepPhr(phrl,n) as clz;

let NthOpt(phrl,n) = NthRepPhr(phrl,n) as opt;

let NthRpt(phrl,n) = NthRepPhr(phrl,n) as rpt;

let NthRptsep(phrl,n) = NthRepPhr(phrl,n) as rptsep;

let NthAlt(phrl,n) = NthRepPhr(phrl,n) as alt;




let type ('lexMode,'lex,'clz,'info,'synStream)BLD %BasicLanguageData% <=> (|
    lxclType : LxclType;  %Memo: Is this still needed?%
    lxclsetClass : LxclsetClass;
    lexOfValidTok : string -> 'lex;
    tokOfLex : 'lex -> string;
    lexHasWord : 'lex # string -> bool;
    lxclOfLex' : ('lex,'clz,'info,'synStream)Lex' -> Lxcl;
    lexHasDictionary : 'lex -> bool;
    syclType : SyclType;
    lexModeOfSycl : Sycl -> 'lexMode;
    defaultInfo : 'lex -> 'info;
    syntaxDictionary : ('lex,'clz,'info,'synStream)Lex' Dictionary;
    lxclSyntaxTable : ('lex,'clz,'info,'synStream)IruleTable array;
    readLexFromBufStream : BufStream -> 'lexMode -> 'lex;
    raiseType : Sycl # Sycl # 'clz -> 'clz
|);


% This should only be applied to Ide, StarIde, StarSymbolIde, StarAlphaIde, or
  Nonide Lex items %
let NewKnownLex'(bld,lex) =
    absLex'(|
        Lex = lex;
        WordInfo = A (|
            IruleTable = absIruleTable(ref None);
            MruleTable = absMruleTable(ref None);
            Reserved = ref false;
            OtherInfo = repBLD(bld).defaultInfo(lex) |) |);

let SyntaxDictionarySize = 101

ins NewSyntaxTables(| lxclType; outLex' |) = (|
    syntaxDictionary = NewDictionary(
        SyntaxDictionarySize,
        (\t. failwith `NotFound`),
        (\(t,o,n). failwith `DuplicateInSyntaxDictionary`),
        outtok,
        outLex' ): ('lex,'clz,'info,'synStream)Lex' Dictionary;
    lxclSyntaxTable =
        ArrayOfFn(
            NumOfLxcls(lxclType),
            (\_.absIruleTable(ref None))
        ): ('lex,'clz,'info,'synStream)IruleTable array  |);


let Lex'OfLexWithTok(bld,lex,tok) =
    if repBLD(bld).lexHasDictionary(lex) then (
        FetchFromDictionary(repBLD(bld).syntaxDictionary,tok)
        ?? "NotFound" UnknownLex'(lex) )
    else UnknownLex'(lex);

let Lex'OfLex(bld,lex) =
    if repBLD(bld).lexHasDictionary(lex) then (
        FetchFromDictionary(
            repBLD(bld).syntaxDictionary, repBLD(bld).tokOfLex(lex) )
        ?? "NotFound" UnknownLex'(lex) )
    else UnknownLex'(lex);

let Lex'OfValidTok(bld,tok) =
    Lex'OfLexWithTok( bld, repBLD(bld).lexOfValidTok(tok), tok );

let EnsureKnownLex'OfValidWord(bld,word) =
    let lex = repBLD(bld).lexOfValidTok(word)
    enc lex' = Lex'OfLexWithTok(bld,lex,word)
    in
        if IsKnownLex'(lex') then lex'
        else
            let lex' = NewKnownLex'(bld,lex) in (
                AddToDictionary(repBLD(bld).syntaxDictionary,word,lex');
                lex' );




% Generic Lex' Stream package %

let type ('lexMode,'lex,'clz,'info,'synStream)Lex'Stream <=> (|
    lexStream: ('lexMode,'lex)LexStream;
    readLex': 'lexMode -> ('lex,'clz,'info,'synStream)Lex' |)

with { NewLex'Stream(bld,lexStream) =
    let readLex = ReadLexStream(lexStream)
    enc readLex'(lexMode) = Lex'OfLex(bld,readLex(lexMode))
    in
        absLex'Stream(| lexStream; readLex' |)

and ReadLex'Stream lex'Stream %lexMode% =
    repLex'Stream(lex'Stream).readLex' %lexMode%

and BreakLex'Stream(lex'Stream) =
    BreakLexStream(repLex'Stream(lex'Stream).lexStream)

and AbortToInteractiveLex'Stream(lex'Stream) =
    AbortToInteractiveLexStream(repLex'Stream(lex'Stream).lexStream)

and CloseLex'Stream(lex'Stream) =
    CloseLexStream(repLex'Stream(lex'Stream).lexStream) };




let EmptyTok = `[empty]`;

%
let ClearSyntaxTables() = (
    ClearDictionary(SyntaxDictionary);
    AppArray (\irt.repIruleTable(irt):=None) LxclSyntaxTable;
    EmptyLex'Ref := EnsureKnownLex'OfValidWord(EmptyTok);
    newline(1); outtok(`Syntax tables cleared`); newline(2) );
%


let ReserveValidWord(bld,word) =
    KnownOfLex'(EnsureKnownLex'OfValidWord(bld,word)).Reserved := true;

% Should only be applied to reservable "Lex'"s %
let IsReservedLex'(lex') = !(KnownOfLex'(lex').Reserved) ?? ExcOpt false;


let IruleTableForLxcl(bld,class) =
    repBLD(bld).lxclSyntaxTable sub OrdLxcl(class);


let FetchFromIruleTable(irt,tt) =
    The( The(!repIruleTable(irt)) sub OrdSycl(tt) );

let UpdateIruleTable(bld,irt,tt,rule) =
    let rep = repIruleTable(irt)
    enc arr =
        The(!rep)
        ?? ExcOpt
            let arr = array(NumOfSycls(repBLD(bld).syclType),None) in
                (rep:=An(arr); arr)
    in
        update(arr,OrdSycl(tt),An(rule));

let RemoveFromIruleTable(irt,tt) =
    update(The(!repIruleTable(irt)),OrdSycl(tt),None) ?? ExcOpt ();


let FetchFromMruleTable(mrt,tt,pty) =
    The(
        The( The(!repMruleTable(mrt)) sub OrdSycl(pty) )
        sub OrdSycl(tt) );

let UpdateMruleTable(bld,mrt,tt,pty,rule) =
    let rep = repMruleTable(mrt)
    enc arr =
        The(!rep)
        ?? ExcOpt
            let arr = array(NumOfSycls(repBLD(bld).syclType),None) in (
                rep := An(arr);  arr )
    enc arr' =
        The( arr sub OrdSycl(pty) )
        ?? ExcOpt
            let arr' = array(NumOfSycls(repBLD(bld).syclType),None) in (
                update(arr,OrdSycl(pty),An(arr'));  arr' )
    in
        update(arr',OrdSycl(tt),An(rule));

let RemoveFromMruleTable(mrt,pty) =
    update(The(!repMruleTable(mrt)),OrdSycl(pty),None) ?? ExcOpt ();


let IruleForClass(bld,class,tt) =
    FetchFromIruleTable( IruleTableForLxcl(bld,class), tt );


let IruleForLex'(bld,lex',tt) =
    FetchFromIruleTable(The(repLex'(lex').WordInfo).IruleTable,tt)
    ?? ExcOpt IruleForClass(bld,repBLD(bld).lxclOfLex'(lex'),tt);

let MruleForLex'(lex',tt,pty) =
    FetchFromMruleTable(The(repLex'(lex').WordInfo).MruleTable,tt,pty);


let { { { {
    WarnForTargetSycls(bld,ttl) =
        if null ttl then ()
        else (
            bell();
            outtok(
                `WARNING:  More than one rule for target syntax class(es): `);
            PrSyclList (repBLD(bld).syclType) ttl;  newline(1) )

ins { CheckIruleIsNew(bld,irt,ttl) =
    WarnForTargetSycls(
        bld,
        join
            (\tt. ( Do(FetchFromIruleTable(irt,tt)); [tt] ) ?? ExcOpt nil )
            ttl )

and CheckMruleIsNew(bld,mrt,ttl,pty) =
    WarnForTargetSycls(
        bld,
        join
            (\tt.
                ( Do(FetchFromMruleTable(mrt,tt,pty)); [tt] )
                ?? ExcOpt nil)
            ttl ) } }

ins { AddNewIruleToTable(bld,irt,ttl,rule) = (
    CheckIruleIsNew(bld,irt,ttl);
    app (\tt.UpdateIruleTable(bld,irt,tt,rule)) ttl )

and AddNewMruleToTable(bld,mrt,ttl,pty,rule) = (
    CheckMruleIsNew(bld,mrt,ttl,pty);
    app (\tt.UpdateMruleTable(bld,mrt,tt,pty,rule)) ttl ) } }

ins { AddNewIruleForWord(bld,word,ttl,rule) = (
    if !Debug.NewRules then (
        outtok(`Defining initial rule for word `); printtok(word); newline(1);
        outtok(`in target syntax class contexts `);
            PrSyclList (repBLD(bld).syclType) ttl; newline(1) )
    else ();
    AddNewIruleToTable(
        bld,
        IruleTableOfKnownLex'(EnsureKnownLex'OfValidWord(bld,word)),
        ttl,
        rule );
    if !Debug.NewRules then newline(1) else () )

and AddNewIruleForClass(bld,lxclset,ttl,rule) = (
    if !Debug.NewRules then (
        outtok(`Defining initial rule for lexical class set `);
            PrLxclset(lxclset); newline(1);
        outtok(`in target syntax class contexts `);
            PrSyclList (repBLD(bld).syclType) ttl; newline(1) )
    else ();
    AppLxclset
        (\lxcl. AddNewIruleToTable(bld,IruleTableForLxcl(bld,lxcl),ttl,rule) )
        lxclset;
    if !Debug.NewRules then newline(1) else () )

and AddNewMruleForWord(bld,word,ttl,pty,rule) = (
    if !Debug.NewRules then (
        outtok(`Defining medial rule for word `); printtok(word); newline(1);
        outtok(`in target syntax class contexts `);
            PrSyclList (repBLD(bld).syclType) ttl;  newline(1);
        outtok(`in previous syntax class context `);
            PrSycl (repBLD(bld).syclType) pty;  newline(1) )
    else ();
    AddNewMruleToTable(
        bld,
        MruleTableOfKnownLex'(EnsureKnownLex'OfValidWord(bld,word)),
        ttl,
        pty,
        rule );
    if !Debug.NewRules then newline(1) else () ) } }

and { type FormSeqAnalysis = [|
    initialWord: Word;
    initialClass: Lxclset;
    medial: Word # BindingPower # Sycl list |] } }

ins { { rec AnalyseClzalt(bp,ttl,rfl) =
    case AnalyseFormSeq rfl of [|
    initialWord = wd . [| medial = wd, bp, ttl |];
    initialClass . failwith `AnalyseFormSeq`;
    medial . failwith `AnalyseFormSeq` |]

and AnalyseFormSeq fl =
    if null fl then failwith `AnalyseFormSeq`
    else
        let f::rfl = fl in
            case repForm f of [|
            word = wd . [| initialWord = wd |];
            class = lxclset . [| initialClass = lxclset |];
            clz = (| bindingPower=bp; targetSycl=tty |) .
                AnalyseClzalt(bp,[tty],rfl);
            clzalt = (| bindingPower=bp; targetSycls=ttl |) .
                AnalyseClzalt(bp,ttl,rfl);
            opt . failwith `AnalyseFormSeq`;
            rpt . failwith `AnalyseFormSeq`;
            rptsep . failwith `AnalyseFormSeq`;
            alt . failwith `AnalyseFormSeq` |]: FormSeqAnalysis }

ins { InstallRuleMade bld (ttyl,rty,fl,fn) =
    let ttyl = map (SyclOfName (repBLD(bld).syclType)) ttyl
    and rty = SyclOfName (repBLD(bld).syclType) rty
    in
        case AnalyseFormSeq fl of [|
        initialWord = wd .
            AddNewIruleForWord(
                bld, wd, ttyl, NormalWordIrule(rty,tl(fl),fn) );
        initialClass = lxclset .
            AddNewIruleForClass(
                bld, lxclset, ttyl, NormalClassIrule(rty,tl(fl),fn) );
        medial = wd, lbp, ptyl .
            let r = Mrule(lbp,rty,tl(tl(fl)),fn) in
               app (\pty.AddNewMruleForWord(bld,wd,ttyl,pty,r)) ptyl |]

enc InstallRule bld (ttyl,rty,l,fn) =
    InstallRuleMade
        bld
        (   ttyl,
            rty,
            MakeFormSeq(
                repBLD(bld).lxclsetClass,
                repBLD(bld).syclType,
                BuildTokTreeList(l) ),
            fn )

enc InstallFunctionalIruleForWord bld (word,ttl,fn) =
    AddNewIruleForWord(
        bld,
        word,
        map (SyclOfName (repBLD(bld).syclType)) ttl,
        absIrule[| functional = fn |] ) } };




let { rec partrev'(n,r,l) =
    if n=0 then r
    else if null l then r
    else let x::l = l in partrev'(n-1,x::r,l) }
ins
    partrev(n,l) = partrev'(n,nil,l);


%
let PrPhrSeqGen(| bld; prLxcl; prLex; refPrClz; indentStep |) =
    let rec PrPhr i phr =
        case repPhr phr of [|
        word = lex' . (
            space(i); outtok(`word `); prLex(LexOfLex'(lex')); newline(1) );
        class = lex' . (
            space(i); outtok(`class `); prLxcl(repBLD(bld).lxclOfLex'(lex'));
            outtok(` - lex `); prLex(LexOfLex'(lex')); newline(1) );
        clz = clz . {This should tab to i then print with newline}
            (!refPrClz)(i,clz);
        opt = opt .
            ( space(i); outtok(`opt - `);
                case opt of [|
                failure . ( outtok(`failed`); newline(1) );
                success = phrl . (
                    outtok(`succeeded`); newline(1);
                    PrPhrSeq (i+indentStep) phrl ) |] );
        rpt = rpt .
            ( space(i); outtok(`rpt`); newline(1);
                PrPhrSeqSeq (i+indentStep) rpt );
        rptsep = rptsep .
            ( space(i); outtok(`rptsep`); newline(1);
                PrPhrSeqSeq (i+indentStep) rptsep );
        alt = (| altNum; phrSeq |) .
            ( space(i); outtok(`alt `); printint(altNum); newline(1);
                PrPhrSeq (i+indentStep) phrSeq ) |]
    
    and PrPhrSeq i phrl = app (PrPhr i) phrl
    
    and PrPhrSeqSeq i phrll = app (PrPhrSeq i) phrll
    
    in
        PrPhrSeq;
%


let type ParseFail = [|
    none      : unit;
    word      : string;
    class     : Lxclset;
    rpt       : unit;
    rptsep    : unit;
    alt       : unit;
    initial   : Sycl;
    clz       : (| target: Sycl; got: Sycl |);
    other     : string |];

let OutParseFail(bld,pf) =
    case pf of [|
    none . outtok(`No error recorded!`);
    word = wd . ( outtok(`Was expecting "`); outtok(wd); outtok(`"`) );
    class = lxclset . ( outtok(`Was expecting `); PrALxclset lxclset );
    rpt . outtok(`Insufficient repetition`);
    rptsep . outtok(`Insufficient repetition`);
    alt . outtok(`None of possible alternatives`);
    initial = tt . (
        outtok(`Was expecting `); PrASycl (repBLD(bld).syclType) tt );
    clz = (| target = tt; got = clt |) . (
        outtok(`Was expecting `); PrASycl (repBLD(bld).syclType) tt;
        outtok(`, but only got `); PrASycl (repBLD(bld).syclType) clt );
    other = t . outtok(t) |];

let ParseFailRef = ref([| none |]: ParseFail);

let ParseFail e = ( ParseFailRef := e; failwith `Parse` );

let ParseFailFatal e = ( ParseFailRef := e; failwith `FatalParse` );

let ParserGen(| bld; lex'Memstr; synStream |) =

    let { lexHasWord = repBLD(bld).lexHasWord

    and emptyLex' = EnsureKnownLex'OfValidWord(bld,EmptyTok)

    and lxclOfLex' = repBLD(bld).lxclOfLex'

    and lexModeOfSycl = repBLD(bld).lexModeOfSycl

    and raiseType = repBLD(bld).raiseType }
    
    enc { emptyLex'PhrSeq = [ PhrWord(emptyLex') ]
    
    and NextLex'(tt): ('lex,'clz,'info,'synStream)Lex' =
        NextMemstr(lexModeOfSycl(tt),lex'Memstr)

    and ReadLex'(tt): ('lex,'clz,'info,'synStream)Lex' =
        ReadMemstr(lexModeOfSycl(tt),lex'Memstr)

    and Posn() = MemstrPosn(lex'Memstr)

    and Backtrack(p) = BacktrackMemstr(p,lex'Memstr) }

    enc { rec

        ParseFormWord(wd,tt) =
        let lex' = ReadLex'(tt) in
            if lexHasWord(LexOfLex'(lex'),wd) then PhrWord(lex')
            else ParseFail[|word=wd|]

    and ParseFormClass(lxclset,tt) =
        let lex' = ReadLex'(tt)
        in
            if MemberLxclset(lxclOfLex'(lex'),lxclset) then PhrClass(lex')
            else ParseFail[|class=lxclset|]

    and ParseFormClz(bp,tty) =
        PhrClz(ParseClz(tty,bp))

    and ParseFormOpt(fml,tt) =
        let p = Posn() in
            PhrOpt(
                [| success = ParseFormSeq(fml,tt) |]
                ?? "Parse" ( Backtrack(p); [| failure |]) )

    and ParseFormRptSub(phrll,fml,tt) =
        let p = Posn()
        ins phrl = ParseFormSeq(fml,tt) ?? "Parse" ( Backtrack(p); nil )
        in
            if null phrl then rev(phrll)
            else ParseFormRptSub(phrl::phrll,fml,tt)

    and ParseFormRpt(m,fml,tt) =
        let phrll = ParseFormRptSub(nil,fml,tt)
        in
            if length(phrll) >= m then PhrRpt(phrll)
            else ParseFail[|rpt|]

    and ParseFormRptsepSub(phrll,sepfm,fml,tt) =
        let p = Posn()
        ins more = 
            ( Do(ParseForm(sepfm,tt)); true )
            ?? "Parse" ( Backtrack(p); false )
        in
            if more then
                ParseFormRptsepSub(ParseFormSeq(fml,tt)::phrll,sepfm,fml,tt)
            else
                rev(phrll)

    and ParseFormRptsep(m,sepfm,fml,tt) =
        let { p = Posn()
        ins phrl = ParseFormSeq(fml,tt) ?? "Parse" (Backtrack(p); nil) }
        enc phrll =
            if null phrl then nil
            else ParseFormRptsepSub([phrl],sepfm,fml,tt)
        in
            if length(phrll) >= m then PhrRptsep(phrll)
            else ParseFail[|rptsep|]

    and ParseFormAltSub(n,fmll,tt) =
        if null fmll then ParseFail[|alt|]
        else
            let p = Posn()
            ins phrl =
                ParseFormSeq(hd(fmll),tt) ?? "Parse" ( Backtrack(p); nil )
            in
                if null phrl then ParseFormAltSub(n+1,tl(fmll),tt)
                else (| altNum=n; phrSeq=phrl |)

    and ParseFormAlt(fmll,tt) =
        PhrAlt(ParseFormAltSub(1,fmll,tt))

    and ParseForm(fm,tt) =
        case repForm fm of [|
        word = wd . ParseFormWord(wd,tt);
        class = lxclset . ParseFormClass(lxclset,tt);
        clz = (| bindingPower=bp; targetSycl=tty |) .
            ParseFormClz(bp,tty);
        clzalt . failwith `Parser Crash:  Invalid Syntax Rule`;
        opt = fml . ParseFormOpt(fml,tt);
        rpt = (| minRpt=m; formSeq=fml |) . ParseFormRpt(m,fml,tt);
        rptsep = (| minRpt=m; sep=sepfm; formSeq=fml |) .
            ParseFormRptsep(m,sepfm,fml,tt);
        alt = fmll . ParseFormAlt(fmll,tt) |]

    and ParseFormSeqSub(phrl,fml,tt) =
        if null fml then rev(phrl)
        else ParseFormSeqSub(ParseForm(hd fml,tt)::phrl,tl fml,tt)

    and ParseFormSeq(fml,tt) = ParseFormSeqSub([],fml,tt)

    and ParseMrule(formSeq,semfn,prevcl,lx',tt) =
        let phrl = ParseFormSeqSub([],formSeq,tt) in
            semfn( PhrClz(prevcl) :: PhrWord(lx') :: phrl )

    and ParseInitial(tt) =
        ( let lx' = NextLex'(tt) in
            case repIrule(IruleForLex'(bld,lx',tt)) of [|
                normalWord = (| resultSycl; formSeq; semfn |) . (
                    SkipGotMemstr(lex'Memstr);
                    (   semfn(PhrWord(lx')::ParseFormSeqSub([],formSeq,tt)),
                        resultSycl ) );
                normalClass = (| resultSycl; formSeq; semfn |) . (
                    SkipGotMemstr(lex'Memstr);
                    (   semfn(PhrClass(lx')::ParseFormSeqSub([],formSeq,tt)),
                        resultSycl ) );
                functional = f . f(synStream)(tt) |] )
        ?? ExcOpt ( (
            let (| resultSycl; formSeq=_; semfn |) =
                repIrule(IruleForLex'(bld,emptyLex',tt)) as normalWord
            in
                ( semfn(emptyLex'PhrSeq), resultSycl ) )
        ?? ExcOpt
            ParseFail[|initial=tt|] )

    and ParseMedial(tt,prevcl,prevclt,bp) =
        (   let lx' = NextLex'(tt)
            enc (| leftBindingPower; resultSycl; formSeq; semfn |) =
                repMrule(MruleForLex'(lx',tt,prevclt))
            in
                if leftBindingPower >= bp then (
                    SkipGotMemstr(lex'Memstr);
                    [| success = ( 
                        ParseMrule(formSeq,semfn,prevcl,lx',tt),
                        resultSycl ) |] )
                else
                    [| failure |] )
        ?? ExcOpt ( (
            let (| leftBindingPower; resultSycl; formSeq; semfn |) =
                repMrule(MruleForLex'(emptyLex',tt,prevclt))
            in
                if leftBindingPower >= bp then
                    let p = Posn() in (
                        [| success = (
                            ParseMrule(formSeq,semfn,prevcl,emptyLex',tt),
                            resultSycl ) |]
                        ?? "Parse" ( Backtrack(p); [| failure |] ) )
                else
                    [| failure |] )
        ?? ExcOpt
            [| failure |] )

    and ParseClzSub(tt,cl,clt,bp) =
        case ParseMedial(tt,cl,clt,bp) of [|
        success = cl,clt . ParseClzSub(tt,cl,clt,bp);
        failure . cl,clt |]

    and TryParseClz(tt,bp) =
        let cl, clt = ParseInitial(tt) in ParseClzSub(tt,cl,clt,bp)

    and ParseClz(tt,bp) =
        let cl, clt = TryParseClz(tt,bp)
        in
            raiseType(clt,tt,cl)
            ?? "raiseType" ParseFail[| clz = (|target=tt;got=clt|) |] }

    in
        (| ParseFormSeq; ParseClz; TryParseClz |);




% Generic Abstract Syntax Stream package %

let type rec ('lexMode,'lex,'clz,'info)SynStream <=> (|
    bld: (
        'lexMode, 'lex, 'clz, 'info,
        ('lexMode,'lex,'clz,'info)SynStream )BLD;
    lex'Stream: (
        'lexMode, 'lex, 'clz, 'info,
        ('lexMode,'lex,'clz,'info)SynStream )Lex'Stream;
    lex'Memstr: (
        'lexMode,
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Lex' )Memstr;
    readFormSeqRef:
        (       Form list # Sycl
            ->
                ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Phr
                list  )
        ref;
    readClzRef: (Sycl # BindingPower -> 'clz) ref;
    tryReadClzRef: (Sycl # BindingPower -> 'clz # Sycl) ref |)

with {
    NewSynStream
        ( bld : (
            'lexMode, 'lex, 'clz, 'info,
            ('lexMode,'lex,'clz,'info)SynStream )BLD )
        ( bufStream : BufStream )
    : ('lexMode,'lex,'clz,'info)SynStream
    =
        let readLexFromBufStream = repBLD(bld).readLexFromBufStream
        enc lexStream = NewLexStream(| bufStream; readLexFromBufStream |)
        enc lex'Stream = NewLex'Stream(bld,lexStream)
        enc lex'Memstr = NewMemstr( ReadLex'Stream(lex'Stream), `FatalParse` )
        enc readFormSeqRef = ref DummyFun
        enc readClzRef = ref DummyFun
        enc tryReadClzRef = ref DummyFun
        enc synStream = absSynStream(|
            bld; lex'Stream; lex'Memstr;
            readFormSeqRef; readClzRef; tryReadClzRef |)
        enc (| ParseFormSeq; ParseClz; TryParseClz |) =
            ParserGen(| bld; lex'Memstr; synStream |)
        in (
            readFormSeqRef := ParseFormSeq;
            readClzRef := ParseClz;
            tryReadClzRef := TryParseClz;
            synStream )

and BldOfSynStream(synStream) = repSynStream(synStream).bld

and ReadLex'SynStream(synStream)(lexMode) =
    ReadMemstr(lexMode,repSynStream(synStream).lex'Memstr)

and ReadFormSeqSynStream(synStream) = !repSynStream(synStream).readFormSeqRef

and ReadClzSynStream(synStream) = !repSynStream(synStream).readClzRef

and TryReadClzSynStream(synStream) = !repSynStream(synStream).tryReadClzRef

and Lex'MemstrListSynStream(synStream) =
    MemstrList(repSynStream(synStream).lex'Memstr)

and BreakSynStream(synStream) = (
    BreakMemstr(repSynStream(synStream).lex'Memstr);
    BreakLex'Stream(repSynStream(synStream).lex'Stream) )

and AbortToInteractiveSynStream(synStream) = (
    ClearMemstr(repSynStream(synStream).lex'Memstr);
    AbortToInteractiveLex'Stream(repSynStream(synStream).lex'Stream) )

and CloseSynStream(synStream) = (
    ClearMemstr(repSynStream(synStream).lex'Memstr);
    CloseLex'Stream(repSynStream(synStream).lex'Stream) ) };



let type {
    ('lexMode,'lex,'clz,'info)Irule =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Irule
and
    ('lexMode,'lex,'clz,'info)Mrule =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Mrule
and
    ('lexMode,'lex,'clz,'info)IruleTable =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )IruleTable
and
    ('lexMode,'lex,'clz,'info)MruleTable =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )MruleTable
and
    ('lexMode,'lex,'clz,'info)Lex' =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Lex'
and
    ('lexMode,'lex,'clz,'info)Phr =
        ( 'lex, 'clz, 'info, ('lexMode,'lex,'clz,'info)SynStream )Phr
and
    ('lexMode,'lex,'clz,'info)BasicLanguageData =
        (   'lexMode, 'lex, 'clz, 'info,
            ('lexMode,'lex,'clz,'info)SynStream )BLD
and
    ('lexMode,'lex,'clz,'info)Lex'Stream =
        (   'lexMode, 'lex, 'clz, 'info,
            ('lexMode,'lex,'clz,'info)SynStream )Lex'Stream
};



let type ('lexMode,'lex,'clz,'info)SysState <=> (|
    sysTitle: string;
    bufStream: BufStream;
    synStream: ('lexMode,'lex,'clz,'info)SynStream;
    topEnvRef: TopAllEnv' ref |)

with
    NewSysState(sysTitle,bufStream,synStream,topEnv) =
        absSysState(| sysTitle; bufStream; synStream; topEnvRef = ref topEnv |)
and
    SysTitleOfSysState(sysState) = repSysState(sysState).sysTitle
and
    BufStreamOfSysState(sysState) = repSysState(sysState).bufStream
and
    SynStreamOfSysState(sysState) = repSysState(sysState).synStream
and
    TopEnvOfSysState(sysState) = !repSysState(sysState).topEnvRef
and
    UpdateTopEnvOfSysState(sysState,topEnv) =
        repSysState(sysState).topEnvRef := topEnv
and
    UseFileInSysState sysState bufSize fileName =
        UseFile( fileName, bufSize, repSysState(sysState).bufStream )
and
    UseStringInSysState sysState String =
        UseString( String, repSysState(sysState).bufStream )
and
    AbortToInteractiveSysState(sysState) =
        AbortToInteractiveSynStream(repSysState(sysState).synStream)
        % Could also do something useful to the TopEnv! %
;
