% MLABSCON.ML %

let optOfOpt( x: 'a Opt ): 'a opt =
    if Exists(x) then [| present = The(x) |] else [| absent |];


% Remember to define DummyFun & optOfOpt early enough! %



% This file contains the Constructor Functions for ML Abstract Syntax %


let MLNumLabOfInt( i: int ): string =
    let s = tokofint(i)
    enc n = LengthTok(s)
    in substring(`#00`,1,4-n) #@ s;

let { rec f l = if null l then [] else `.` :: hd(l) :: f(tl(l)) }

ins MLQualIdeOfStringList( l: string list): string =
    if null l then failwith `MLQualIdeOfStringList`
    else implode( hd(l) :: f(tl(l)) );


% Constructors for Constants %

let MLSynKonstInt( i: int ): SynConst' = [|int=i|];

let MLSynKonstReal( r: real ): SynConst' = [|real=r|];

let MLSynKonstString( s: string ): SynConst' = [|string=s|];




% Constructors for Atoms %

let MLAtomDummy = dummyAtom: Atom';



% Constructors for Binding-occurrences of Identifiers %

let type SynBindIdeKind' = [|
    no;
    yes: ([|variant;pointer;zero;ref;xcon:int ref|] # int # int # bool) ref |];

let MLBindoccIde(|
    ide=ide: Atom';
    kind=kind: SynBindIdeKind';
    inline=inline: InlineCode';
    SMorUser=SMorUser: SMorUser';
    arity=arity: int |)
: SynBindIde'
= (|
    Ide = ide;
    References = ref 0;
    Constructor = kind;
    Inline = ref inline;
    StkPosn = ref [| Local = ~1 |];
    MinFunArity = ref MaxInt;
    NativeCoded = ref false;
    SMorUser;
    UserArity = ref arity |);  %NB default is ~1%

let MLBindoccIdeDummy =
    MLBindoccIde(|
        ide = MLAtomDummy;
        kind = [|no|];
        inline = [|absent|];
        SMorUser = [|NonPrimitive|];
        arity = ~1 |)
    : SynBindIde';

let MLExtraSyntaxDict =
    NewDictionary(
        32,
        (\(_). (| opcode = 0; arity = ~1 |) ),  %junkie default%
        (\(t,o,n). n),
        outtok,
        DummyFun );

% TEMPORARY DEFINITION(?):- %
let MLExtraForIde( ide: Atom' ): (| opcode: int; arity: int |) =
    let t = repAtom'(ide)
    enc y = FetchFromDictionary(MLExtraSyntaxDict,t)
    enc () =
        if y.arity <> ~1 then RemoveFromDictionary(MLExtraSyntaxDict,t) else ()
    in
        y;

let MLBindoccIdeExtra(| ide=ide: Atom'; kind=kind: SynBindIdeKind' |)
: SynBindIde'
=
    let (|opcode;arity|) = MLExtraForIde(ide)
    enc inline =
        case kind of [|
            no .
                if opcode=0 then [|absent|]
                else [| present = (0,0,[absSMCode'[|OpPrimitive=opcode|]]) |];
            yes .
                [| present = (0,0,[]) |] |]
        : InlineCode'
    enc SMorUser =
        (if opcode=255 then [|OverLoaded|] else [|NonPrimitive|]): SMorUser'
    in
        MLBindoccIde(|ide;kind;inline;SMorUser;arity|);

let MLOverload(idname: Atom', overtype: SynTypTerm') =
    let typ = AnalyseTypTerm(overtype, [], ref [], false, false) 
    enc _ = FlagGenericVarsInNilEnv(typ) in 
    UpdateTopValEnv(outr(!AnalTopEnv).Val,
                    MLBindoccIde(|ide=idname;
                                  kind=[|no|];
                                  inline=[|absent|];
                                  SMorUser = [|OverLoaded|];
                                  arity=1|),
                    typ,mkobj ());

let MLBindoccVal( ide: Atom' ): SynBindIde' =
    MLBindoccIdeExtra(| ide; kind=[|no|] |);

let MLBindoccConstr( ide: Atom', implicit: bool ): SynBindIde' =
    MLBindoccIdeExtra(|
        ide;
        kind = [| yes = ref([|variant|],0,0,implicit) |] |);

%RJGDEL let MLBindoccExc( ide: Atom' ): SynBindIde' =%
%RJGDEL     MLBindoccIdeExtra(| ide; kind=[|no|] |);%

%AM: Used only by InitEnv in MLMAIN.ML:- %
let AllocBindIde( ide: Atom' ): SynBindIde' =
    MLBindoccIdeExtra(| ide; kind=[|no|] |);

%AM: Used only by InitEnv in MLMAIN.ML:- %
let AllocBindPseudo( ide: Atom', Op%: ?% ): SynBindIde' =
    MLBindoccIde(|
        ide;
        kind = [|no|];
        inline = [|absent|];
        SMorUser = [|PseudoOp=Op|];
        arity = ~1 |);


% Constructors for Expressions %

let MLSynExpIde( ide: Atom' ): SynTerm' =
    absSynTerm'[|SynIde=(|
        Ide = ide; LastUse = ref false; 
        Binder = ref DummyFun; MonoType = ref dummyTypTerm |)|];

let MLSynExpKonst( k: SynConst' ): SynTerm' = absSynTerm'[|SynConst=k|];

let MLSynExpInt( i: int ): SynTerm' = MLSynExpKonst(MLSynKonstInt(i));

let MLSynExpReal( r: real ): SynTerm' = MLSynExpKonst(MLSynKonstReal(r));

let MLSynExpString( s: string ): SynTerm' = MLSynExpKonst(MLSynKonstString(s));

let MLSynExpTuple( el: SynTerm' list ): SynTerm' = absSynTerm'[|SynTuple=el|];

let MLSynExpUnit = MLSynExpTuple[];

let MLSynExpTupleOrSingle( el: SynTerm' list ): SynTerm' =
    if length(el) = 1 then hd(el) else MLSynExpTuple(el);

let MLSynExpList( el: SynTerm' list ): SynTerm' = absSynTerm'[|SynList=el|];

let MLSynExpRecord( l: (Atom' # SynTerm') list ): SynTerm' =
    absSynTerm'[|SynRecord=
        map (\(a,e). (| RecKey = a; RecField = e |)) l |];

let MLSynExpVariant( a: Atom', e: SynTerm' ): SynTerm' =
    absSynTerm'[|SynVariant=(|
        VarKey = a; VarField = e; VarPos = ref DummyFun |)|];

let MLSynExpCond( e1: SynTerm', e2: SynTerm', e3: SynTerm'): SynTerm' =
    absSynTerm'[|SynCond=(| CondIf = e1; CondThen = e2; CondElse = e3 |)|];

let MLSynExpWhile( e1: SynTerm', e2: SynTerm'): SynTerm' =
    absSynTerm'[|SynWhile=(| WhileCond = e1; WhileBody = e2 |)|];

let MLSynExpFun( m: SynMatch' ): SynTerm' =
    absSynTerm'[|SynLamb=(|Match=m; LastUseFreeVar=ref [] |)|];

let MLSynExpCase( e: SynTerm', m: SynMatch' ): SynTerm' =
    absSynTerm'[|SynNewCase=(| Match = m; Select = e |)|];

let MLSynExpAppl( ef: SynTerm', ea: SynTerm', ar: Arity' ): SynTerm' =
    absSynTerm'[|SynAppl=(| Fun = ef; Arg = ea; HowRead = ar |)|];

let MLSynExpVarcase( e: SynTerm', cl: SynTermCase' list ):  SynTerm' =
    absSynTerm'[|SynCase=(| Select = e; Cases = cl |)|];

let MLSynExpJumpcase( e: SynTerm', cl: SynTermCase' list ):  SynTerm' =
    absSynTerm'[|SynJumpcase=(| Select = e; Cases = cl |)|];

let MLSynExpLet( d: SynDecl', e: SynTerm' ): SynTerm' =
    absSynTerm'[|SynLet=(| Decl = d; Scope = e |)|];

let
    MLSynExpQua
        ( q: [| SynQuaDot; SynQuaIs; SynQuaAs |] )
        ( e: SynTerm', k: Atom' )
    : SynTerm'
    =   absSynTerm'[|SynQuaOp=(|
            QuaOp = q; QuaIde = k; QuaArg = e; QuaPos = ref DummyFun |)|]
ins {
    MLSynExpDot = MLSynExpQua[|SynQuaDot|]: SynTerm' # Atom' -> SynTerm'
and
    MLSynExpIs = MLSynExpQua[|SynQuaIs|]: SynTerm' # Atom' -> SynTerm'
and
    MLSynExpAs = MLSynExpQua[|SynQuaAs|]: SynTerm' # Atom' -> SynTerm' };

let MLSynExpForce( e: SynTerm', t: SynTypTerm' ): SynTerm' =
    absSynTerm'[|SynForce=(| ForceTerm = e; ForceType = t |)|];

let MLSynExpTagType( Purpose: [|Print; Dynamic; Cast|], 
                     e: SynTerm' ): SynTerm' =
    absSynTerm'[|SynTagType=(| Arg = e; Purpose=Purpose; 
                 Type = ref dummyTypTerm |)|];

let MLSynExpTrapAll( expLft: SynTerm', expRht: SynTerm' ): SynTerm' =
    absSynTerm'[|SynTrap=(|
        TrapLft = expLft; TrapRht = expRht; TrapClass = [|SynTrapAll|] |)|];

let MLSynExpTrapList( expLft: SynTerm', expList: SynTerm', expRht: SynTerm' )
: SynTerm'
=   absSynTerm'[|SynTrap=(|
        TrapLft = expLft;
        TrapRht = expRht;
        TrapClass = [|SynTrapList=(|TrapList=expList|)|] |)|];

let MLSynExpTrapLambda( expLft: SynTerm', pat: SynBind', expRht: SynTerm' )
: SynTerm'
=   absSynTerm'[|SynTrap=(|
        TrapLft = expLft;
        TrapRht = expRht;
        TrapClass = [|SynTrapLamb=(|TrapBind=pat|)|] |)|];

let MLSynExpHandle( exp: SynTerm', h: SynMatch' ): SynTerm' =
    absSynTerm'[|SynHandle=(| HandLft = exp; Match = h |)|];

let MLSynExpRaise( ide: Atom', exp: SynTerm' ): SynTerm' =
    absSynTerm'[|SynRaise=(|
        ExcIde = ide;
        ExcBinder = ref MLBindoccIdeDummy; 
        ExcArg = exp |)|];

let MLSynExpSeq( expLft: SynTerm', expRht: SynTerm' ): SynTerm' =
    absSynTerm'[|SynSequence=(| SeqLft=expLft; SeqRht=expRht |)|];




% Constructors, etc. for Patterns %

let MLSynPatIde( ide: Atom' ): SynBind' =
    absSynBind'[| SynBindIde = (|
       Ide = ide; 
       Binder = MLBindoccVal(ide); PreBinder = ref [|absent|] |) |];

let MLAtomOfPatIde( patIde: SynBind' ): Atom' =
    (repSynBind'(patIde) as SynBindIde).Ide;

let MLSynPatAny = absSynBind'[|SynBindAny|]: SynBind';

let MLSynPatKonst( k: SynConst' ): SynBind' = absSynBind'[|SynBindConst=k|];

let MLSynPatInt( i: int ): SynBind' = MLSynPatKonst(MLSynKonstInt(i));

let MLSynPatReal( r: real ): SynBind' = MLSynPatKonst(MLSynKonstReal(r));

let MLSynPatString( s: string ): SynBind' = MLSynPatKonst(MLSynKonstString(s));

let MLSynPatTuple( pl: SynBind' list ): SynBind' =
    absSynBind'[|SynBindTuple=pl|];

let MLSynPatUnit = MLSynPatTuple[]: SynBind';

let MLSynPatTupleOrSingle( pl: SynBind' list ): SynBind' =
    if length(pl) = 1 then hd(pl) else MLSynPatTuple(pl);

let MLSynPatAppl( ide: Atom', p: SynBind', ar: Arity' ): SynBind' =
    absSynBind'[|SynBindAppl=(|
        Ide = ide;
        Binder = ref MLBindoccIdeDummy;
        Arg = p;
        HowRead = ar |)|];

let AtomNil = absAtom' `nil`;

let rec MLSynPatList( pl: SynBind' list ): SynBind' =
    if null pl then MLSynPatIde(AtomNil)
    else 
       MLSynPatAppl(AtomCons, MLSynPatTuple([hd pl; MLSynPatList(tl pl)]), 2);

let MLSynPatRecord( l: (Atom' # SynBind') list, flex: bool ): SynBind' =
    %Memo: "flex" field indicates flexible record pattern %
    absSynBind'[|SynBindRecord=
        ((map (\(a,p). (| RecKey = a; RecField = p |)) l),
         (if flex then [|flexi=ref(\().[])|] else [|solid|]))
       |];

let MLSynPatVariant( a: Atom', p: SynBind' ): SynBind' =
    absSynBind'[|SynBindVariant=(|
        VarKey = a; VarField = p; VarPos = ref DummyFun |)|];

let MLSynPatForce( p: SynBind', t: SynTypTerm' ): SynBind' =
    absSynBind'[|SynBindForce=(| ForceBind = p; ForceType = t |)|];

let MLSynPatBoth( p1: SynBind', p2: SynBind' ): SynBind' =
    absSynBind'[|SynBindBoth=(p1,p2)|];




% Constructors for Rules %

let MLSynRule(p,e) = (p,e);


% Constructors for Matches %

let MLSynMatch(rl) = rl;


% Constructors for Handler Rules %

let MLSynHandlerRuleSpecific( ide: Atom', m: SynMatch' ): SynHandRule' =
    [| Proper = (| 
        HandIde = ide;
        HandBinder = ref MLBindoccIdeDummy; 
        HandAction = m |)|];

let MLSynHandlerRuleGeneral( exp: SynTerm' ): SynHandRule' =
    [| WildCard = (| HandAction = exp; HandExcName = [|absent|] |) |];

let MLSynHandlerRuleTrapLamb( pat: SynBind', exp: SynTerm' ): SynHandRule' =
    [| WildCard = (| HandAction = exp; HandExcName = [|present=pat|] |) |];


% Constructors for Handlers %

let MLSynHandler( hrl: SynHandRule' list ): SynHandler' = hrl;



% Constructors for Types %

let MLSynTypeVar( a: Atom' ): SynTypTerm' =
    absSynTypTerm'[|SynTypVar=(|VarIde=a|)|];

let MLSynTypeCon( ide: Atom', l: SynTypTerm' list ): SynTypTerm' =
    absSynTypTerm'[|SynTypAppl=(| OperIde=ide; Args=l |) |];

let MLSynTypeConNullary( a: Atom' ): SynTypTerm' = MLSynTypeCon(a,nil);

let MLSynTypeUnit = MLSynTypeConNullary(AtomUnit): SynTypTerm';

let MLSynTypeTagCon( tagSort, args ): SynTypTerm' =
    absSynTypTerm'[|SynTypTagAppl=(| TagSort=tagSort; Args=args |)|];



% Constructors for Type Bindings %

let MLSynTypeBindAbbrev( tycon: Atom', tyvars: Atom' list, typ: SynTypTerm' )
: SynDecl'
=
    absSynDecl'[|SynDeclDefTyp=(|
        Bind = tycon;
        TypParams = ref [];
        Params = tyvars;
        TypVarEnv = ref nil;
        DefSort = [|ShortHand=(|SynBinding=typ;TypBinding=ref(dummyTypTerm)|)|] |)|];

% MLSynTypeBindData from mlabscon.ml 				   %
% Changed by RJG 11-Jan-89 for extensible datatypes		   %
% sorting only carried out if non-extensible/extending declaration %

let MLSynTypeBindData(
    tycon: Atom',
    tyvars: Atom' list,
    constrs: (Atom' # SynTypTerm' # bool)list,
    ConstrLt )
: SynDecl'
=
   let filter_constrs (constrs: (Atom' # SynTypTerm' # bool)list):
                      (| SynConstrs: (Atom' # SynTypTerm' # bool)list;
                         Extending: bool;
                         Extensible: bool |) =
   % strips ... constructors from list constrs
     Extending and Extensible have meanings as in SynDeclDef
     list is reversed %

     let mkRes (l,exng,exbl) = (| SynConstrs=l; 
                                  Extending=exng;
                                  Extensible=exbl |)
     enc isDummy(a,_,_) = (repAtom' (a) = repAtom' dummyAtom)

     in if null(constrs) then mkRes(constrs,false,false)
        else
          let rec remove(l,l',exbl) = 
               if null(l) then (l',exbl)
               else let h = hd(l) 
                    in if isDummy(h) then remove(tl l,l',true)
                       else               remove(tl l,h::l',exbl)
          in
            if isDummy(hd constrs) 
            then let (l,ex) = remove(tl constrs,[],false) in mkRes(l,true,ex)
            else let (l,ex) = remove(constrs,[],false) in mkRes(l,false,ex)

   in
   absSynDecl'[|SynDeclDefTyp=(|
        Bind = tycon;
        Params = tyvars;
        TypParams = ref [];
        TypVarEnv = ref nil;
        DefSort = [|Isomorphism=
          let r = filter_constrs(constrs)
%          enc _ = (outtok `*datatype* `;
                   if r.Extensible then outtok `*extbl* ` else ();
                   if r.Extending then outtok `*extng* ` else ();
                   map (\(x,_,_).PrintAtom x) (r.SynConstrs);())
%          in
          (| Extending = r.Extending; Extensible = r.Extensible;
             Constrs =
            sort ((\x:SynDataDef'. repAtom'(x.AbsBinder.Ide)), ConstrLt)
            (map
                ( \( constr: Atom', typ: SynTypTerm', implicit: bool ) . (|
                    Term = typ;
                    ConstrArgType = ref dummyTypTerm;
                    AbsBinder = MLBindoccConstr(constr,implicit) |) )
                (r.SynConstrs)) |) |] |)|];

%RJG 13-Mar-89 - note similarity to MLSynDecVal%
let MLSynDecConBind(v,e) =
    absSynDecl' [|SynDeclDefExcon=(|
				   AbsBinder = (MLBindoccConstr(v,false));
				   Binder = ref DummyFun;
				   CopyIde = e;
                                   ConstrArgType = ref dummyTypTerm |)|];
    


% Constructors for Declarations %

let MLSynDecVal(v,e) =
    absSynDecl'[|SynDeclDefVal=(|
        Bind = v;
        BindType = ref dummyTypTerm;
        Term = e |)|];


let MLSynDecAnd( dec1: SynDecl', dec2: SynDecl' ): SynDecl' =
    absSynDecl'[|SynDeclAnd=(|Lft=dec1;Rht=dec2|)|];

let MLSynDecEnc( dec1: SynDecl', dec2: SynDecl' ): SynDecl' =
    absSynDecl'[|SynDeclEnc=(|Ext=dec1;Int=dec2|)|];

let MLSynDecIns( dec1: SynDecl', dec2: SynDecl' ): SynDecl' =
    absSynDecl'[|SynDeclIns=(|Outs=dec1;Ins=dec2|)|];

let MLSynDecWith( dec1: SynDecl', dec2: SynDecl' ): SynDecl' =
    absSynDecl'[|SynDeclWith=(|WithExt=dec1;WithInt=dec2|)|];

let MLSynDecRec( dec: SynDecl' ): SynDecl' =
    absSynDecl'[|SynDeclRec=(|Rec=dec|)|];


let MLSynDecEmpty(): SynDecl' =
    MLSynDecVal( MLSynPatAny, MLSynExpUnit );

let MLSynDecDir = MLSynDecEmpty;
