% PARSERLIB.ML %
%JJS - several functions moved to LIB.ML%


% General %

let DummyFun _ = fail;



% Integer %

let rec MapIntToList'( f: int -> 'a, i: int, j: int ): 'a list =
    if i>j then [] else f(i) :: MapIntToList'(f,i+1,j);
let MapIntToList (f: int -> 'a) ( i: int, j: int ) : 'a list =
    MapIntToList'(f,i,j);



% List processing %

% TEMPORARY:- %
let tok'member = MemberTok;

let rec join f l = if null l then nil else f(hd l) @ join f (tl l);

let SpecialReduceList f l =
    if null l then failwith `SpecialReduceList`
    else let rec f'(x::l) = if null l then x else f(x,f'(l)) in f'(l);

let auto'cons(x,p) = p := x :: !p;


% Characters %

let type Char = string;

let asc ch = let l = explodeascii(ch) in if null(l) then ~1 else hd(l);

let chr n = implodeascii([n]);

let IsLowerCase(char) = (char #>= `a`) And (char #<= `z`);

let UpperCase(char) = if IsLowerCase(char) then chr(asc(char)-32) else char;

let IsVowel(char) = MemberTok(UpperCase(char),"A E I O U");


% I/O %

let rec space i = if i > 0 then (outtok(` `); space(i-1)) else ();

let bellon = ref true;

let BEL = chr(7) ins bell() = if !bellon then outtok(BEL) else ();


% Names %

let type Name = string;

let ValidateName(name) =
    if LengthTok(name) > 0 then () else failwith `InvalidName`;

let PrName = outtok;

let rec PrNameSeq(l) =
    if null(l) then outtok(`(none)`)
    else if null(tl(l)) then PrName(hd(l))
    else ( PrName(hd(l)); outtok(`, `); PrNameSeq(tl(l)) );

let PrAName(name) = (
    ValidateName(name);
    if IsVowel(hd(explode(name))) then outtok(`an `) else outtok(`a `);
    PrName(name) );

let GenPrPrname(prnameOf)(x) = PrName(prnameOf(x));

let GenPrPrnameList(prnameOf)(l) = PrNameSeq(map prnameOf l);

let GenPrAPrname(prnameOf)(x) = PrAName(prnameOf(x));


% Opt - a new abstract type %

let type 'a Opt <=> unit + 'a
with { A(x) = absOpt(inr(x)) enc An = A }
and None = absOpt(inl())
and The(x) = outr(repOpt(x))
and Exists(x) = isr(repOpt(x))
and ExcOpt = [`Outr`];


% A sorting function - I'm sure this could be much improved! %

let { { rec splitn(n,l1,l2) =
    if n=0 then l1, l2
    else splitn( n-1, tl l1, (hd l1)::l2 ) }
ins
    split(l) = splitn( length(l)/2, l, nil ) }
ins
    sort ( key: 'a -> 'b, lt: 'b # 'b -> bool ) =

    let { rec merge(l1,l2) =
        if null l1 then l2
        else if null l2 then l1
        else
            let x1 = hd l1 and x2 = hd l2 in
                if lt(key(x1),key(x2)) then x1::merge(tl l1,l2)
                else x2::merge(l1,tl l2) }
    ins
        rec sort'sub(l) =
            if length(l)>1 then
                let l1, l2 = split(l) in merge(sort'sub(l1),sort'sub(l2))
            else l
    in
        sort'sub;


% An approximation of Enumeration Types %

let type {

    'id EnumObj <=> int

enc 'id EnumType <=> (|
    Cardinality    :  int;
    NameDictionary :  'id EnumObj Dictionary;
    NameTable : string array;
    PrnameTable :  string array |)

} with {

    failEnum _ = failwith `Enum`

} ins {

    EqEnumObj( eo1: 'id EnumObj, eo2: 'id EnumObj ) =
        repEnumObj(eo1) = repEnumObj(eo2)

and OrdEnumObj = repEnumObj

and NthEnumObj = absEnumObj

and CardinalityOfEnumType(enumType) = repEnumType(enumType).Cardinality

and NameOfEnumObj(enumType: 'id EnumType)(eo: 'id EnumObj): string =
    repEnumType(enumType).NameTable sub repEnumObj(eo)

and PrnameOfEnumObj(enumType: 'id EnumType)(eo: 'id EnumObj) =
    repEnumType(enumType).PrnameTable sub repEnumObj(eo)

and EnumObjOfName(enumType: 'id EnumType)(name): 'id EnumObj =
    FetchFromDictionary(repEnumType(enumType).NameDictionary,name)

and AppEnumObj(enumType: 'id EnumType)(f: 'id EnumObj -> unit): unit =
    let f'(i: int): unit = f(absEnumObj(i))
    in AppInt f' ( 1, repEnumType(enumType).Cardinality )

and MapEnumObjToList(enumType: 'id EnumType)(f: 'id EnumObj -> 'a): 'a list =
    let f'(i: int): 'a = f(absEnumObj(i))
    in MapIntToList f' ( 1, repEnumType(enumType).Cardinality )

and { { rec declareEnumType'(NameDictionary,NameTable,PrnameTable,nameList,i) =
    if null nameList then nil
    else 
        let eo = absEnumObj(i)
        and (name,prname) :: nameList = nameList
        in (
            AddToDictionary(NameDictionary,name,eo);
            update(NameTable,i,name);
            update(PrnameTable,i,prname);
            eo ::
                declareEnumType'(
                   NameDictionary,NameTable,PrnameTable,nameList,i+1)
        ) }

ins DeclareEnumType(nameList): 'id EnumType # ('id EnumObj list) =
    let Cardinality = LengthList nameList
    enc PrnameTable = array(Cardinality,``)
    enc NameTable = array(Cardinality,``)
    enc NameDictionary = NewDictionary(
        Cardinality,
        (\_. failwith `UndeclaredEnumObj`),
        (\_. failwith `DuplicateEnumObjName`),
        failEnum,
        failEnum )
    in (
        absEnumType(| Cardinality; NameDictionary; NameTable; PrnameTable |),
        declareEnumType'(NameDictionary,NameTable,PrnameTable,nameList,1) ) }
};




% Sets as Arrays %

let {
    type 'a SetAsArrayClass <=> (|
        arraySize: int;
        ordFn: 'a -> int;
        nthFn: int -> 'a |)

enc type 'a SetAsArray <=> (|
    array: bool array;
    class: 'a SetAsArrayClass |) }

with {

    NewSetAsArrayClass( arraySize: int, ordFn: 'a -> int, nthFn: int -> 'a )
    : 'a SetAsArrayClass
    =
        absSetAsArrayClass(|arraySize;ordFn;nthFn|)

and SetAsArrayOfList (class: 'a SetAsArrayClass) (l: 'a list) : 'a SetAsArray =
        let (|arraySize;ordFn;nthFn|) = repSetAsArrayClass(class)
        enc array = array(arraySize,false)
        enc () = app (\x. update(array,ordFn(x),true)) l
        in absSetAsArray(|array;class|)

and MemberSetAsArray (ordFn: 'a -> int) ( x: 'a, s: 'a SetAsArray ) : bool =
        repSetAsArray(s).array sub ordFn(x)

and AppSetAsArray (f: 'a -> unit) (s: 'a SetAsArray) : unit =
        let (|array;class|) = repSetAsArray(s)
        enc (|arraySize;ordFn;nthFn|) = repSetAsArrayClass(class)
        enc f'(i: int): unit = if array sub i then f(nthFn(i)) else ()
        in AppInt f' (1,arraySize)

};

%%
%Compound names%

% Split a string of the form head.tail into (head,tail),
  with tail null if no dot. %
let SplitString( str: string ) : string # string =
    let substr(s,start,length) =
	if length <= 0 then `` else substring(s,start,length)
    enc str = str #@ `.`
    enc len = LengthTok(str)
    enc dotpos = ScanTokUntilIn(`.`,str,1,len)
    enc head = substr(str,1,dotpos-1)
    enc tail = substr(str,dotpos+1,len-1-dotpos)
    in (head, tail);

% Turn an identifier into a path. %
let Path( a: Atom' ) : Path' =
    let rec P( s: string ): Path' =
	let (h,t) = SplitString( s )
	enc ha = absAtom'( h )
	in  if t = `` then [ ha ]
	    else ha :: P( t )
    in  P( repAtom'( a ) );

% Spit a path p into its structure prefix and tail. %
let rec Split( p: Path' ) : Path' # Atom' =
    if null( p ) then failwith `split of null path`
    else if null( tl(p) ) then ( nil, hd(p) )
    else let ( pref, tail ) = Split( tl(p) ) in ( hd(p) :: pref , tail );

% Check whether or not an identifier is atomic. %
let IsAtomicIde( a: Atom' ): bool =
    snd( SplitString( repAtom' a ) ) = ``;
