(* kinds *)
knd     : type.

ktype   : knd.
karrow  : list knd -> knd -> knd.

(* types *)
typ       : type.
typconstr : type.
tarrow    : typ -> typ -> typ .
tprod     : list typ -> typ.
tbase     : string -> list typ -> typ.
tpi       : knd -> bindone typ typ -> typ.
typconstr : bindmany typ typ -> typconstr.

constrdef   : type.
csdef       : typconstr -> constrdef.
csdefunit   : constrdef.

(* terms *)
term        : type.
patt        : type.
field       : type.

lam      : bindone term term -> term.
app      : term -> term -> term .
lamt     : bindone typ term -> term.
appt     : term -> typ -> term.
let      : term -> bindone term term -> term.
letrec   : bindmany term (list term * term) -> term.
constr   : string -> term -> term.
construn : string -> term.
ascribe  : term -> typ -> term.
match    : term -> list (bindmany term (patt * term)) -> term.
tuple    : list term -> term.
raise    : term -> term.
trycatch : term -> list (bindmany term (patt * term)) -> term.
record   : map string term -> term.
projrec  : term -> string -> term.
named    : string -> term.

(* patterns *)
ptuple    : list patt -> patt.
pconstr   : string -> patt -> patt.
pconstrun : string -> patt.
pvar      : term -> patt.
pwild     : patt.
pas       : patt -> patt -> patt.
precord   : map string patt -> patt.


(* ----------------------------------------------------------- *)
(* type system. *)


(* context declarations *)
kindofbase         : string -> knd -> prop. (* base constructor *)

type_eq_def        : string -> list knd -> typconstr -> prop.
type_variant_def   : string -> list knd -> list (string * constrdef) -> prop.
type_record_def    : string -> list knd -> map string typconstr -> prop.

constructor_def : string -> constrdef -> string -> prop.
field_def       : string -> typconstr -> string -> prop.

named_gentypeof : string -> typ -> prop.


(* kinds *)
kindof       : typ -> knd -> prop .
kindofg      : typ -> knd -> prop .
kindofall    : list typ -> knd -> prop.
kindofconstr : typconstr -> knd -> prop.


kindof T K :- guard T (kindofg T K).
kindofg (tarrow T1 T2) ktype :- kindof T1 ktype, kindof T2 ktype.
kindofg (tpi K TF)     ktype :- bindone.open TF (pfun x t => (kindofg x K -> kindof t ktype)).
kindofg (tprod TS)     ktype :- kindofall TS ktype.
kindofg (tbase T TS)   K     :- guard T (kindofbase T (karrow KS K)), map kindof TS KS.

kindofall TS K :- map (fun t res => kindof t K) TS _.

(* normal form of types *)
typapply : typconstr -> list typ -> typ -> prop.
typapply (typconstr TC) TS T :- bindmany.apply TC TS T.

nf         : typ -> typ -> prop.
nf_        : typ -> typ -> prop.

nf X Y :- if refl.isunif X then eq X Y else nf_ X Y.

(nf_ X X) when refl.isnvar X.
nf_ (tbase TypConstr TypArgs) (tbase TypConstr TypArgs') :-
  map nf TypArgs TypArgs'.
nf_ (tbase TypConstr TypArgs) T :-
  type_eq_def TypConstr _ Def,
  typapply Def TypArgs T.
nf_ (tbase TypConstr TypArgs) T :-
  type_eq_def TypConstr _ Def,
  typapply Def TypArgs T0,
  nf T0 T.
nf_ X Y when (refl.isbaseterm X, not(eq X (tbase _ _))) :-
  structural @nf X Y.


(* term typing *)

typeof    : term -> typ -> prop.


typeof (lam E) (tarrow T1 T2) :-
  bindone.open E (pfun x e =>
    (typeof x T1 -> typeof e T2)
  ), kindof T1 ktype.

typeof (app E1 E2) T2 :-
  typeof E1 (tarrow T1 T2), typeof E2 T1.

typeof (lamt A_E) (tpi K A_T) :-
  bindone.pair A_E A_T A_ET,
  bindone.open A_ET (pfun a (E, T) =>
    (kindofg a K -> typeof E T)
  ).

typeof (appt E T) T' :-
  typeof E (tpi K TF), bindone.apply TF T T', kindof T K.

typeof (tuple ES) (tprod TS) :- map typeof ES TS.

typeof (ascribe E T) T :- typeof E T.

typeof (raise E) T     :- typeof E (tbase "exn" nil), kindof T ktype.

gentypeof : term -> typ -> prop.

(* implicit generalization/instantiation and so on *)
typinst : typ -> typ -> prop.
typinst (tpi K TF) T' :- bindone.apply TF Tnew Tres, typinst Tres T'.
typinst T T' when not(eq T (tpi _ _)) :- (eq T T'; nf T T').

notinenv : typ -> prop.
notinenv X :- refl.assume_get typeof Assumptions,
	      refl.assume_get gentypeof MoreAssumptions,
	      append Assumptions MoreAssumptions AS,
              unifvars AS (XS : list typ),
              not(find (refl.sameunif X) XS _).

next_typgen : typ -> (typ -> typ) -> prop.
next_typgen T F :- refl.getunif T (X : typ),
	           notinenv X,
	           refl.absunif T X F.

typgen : typ -> typ -> prop.
typgen T T :- not(next_typgen T _).
typgen T (tpi K F') :-
  next_typgen T F,
  bindone.open F' (pfun x f' => (kindofg x K -> typgen (F x) f')).

typgenlist : list typ -> list typ -> prop.
typgenlist TS TS' :- map typgen TS TS'.

(typeof X T) when refl.isnvar X, gentypeof X T.
(typeof X T') when refl.isnvar X, gentypeof X T :- typinst T T'.

typeof (named X) T :- named_gentypeof X T.
typeof (named X) T' :- named_gentypeof X T, typinst T T'.

typeof (app E1 E2) T2 :-
  typeof E1 (tarrow T1 T2),
  typeof E2 T1.

valrestr : term -> prop.
valrestr (constr _ _).
valrestr (construn _).
valrestr (lam      _).
valrestr (lamt     _).
valrestr (tuple _).
valrestr (record _).
valrestr (ascribe E _) :- valrestr E.
(valrestr X) when refl.isnvar X.

typeof (let E E') T' :-
  typeof E T, 
  if valrestr E
  then (typgen T Tgen, kindof Tgen ktype, bindone.open E' (pfun x e' => (gentypeof x Tgen -> typeof e' T')))
  else (kindof T ktype, bindone.open E' (pfun x e' => (typeof x T -> typeof e' T') )).

(* let rec *)
typeof (letrec ESE') T' :-

  bindmany.open ESE' (pfun xs defsBody => [Defs Body]
    eq defsBody (Defs, Body),
    assume_many typeof xs TS (map typeof Defs TS),
    if map valrestr Defs
    then (typgenlist TS TSgen, kindofall TSgen ktype,
          assume_many gentypeof xs TSgen (typeof Body T'))
    else (assume_many typeof xs TS (typeof Body T'))
  ).
  
(* constructors *)
typeof (construn C) (tbase Tbase TS) :-
  constructor_def C csdefunit Tbase,
  type_variant_def Tbase KS _,
  map kindof TS KS.

typeof (constr C Params) (tbase Tbase TS) :-
  constructor_def C (csdef PolyParamsT) Tbase,
  type_variant_def Tbase KS _,
  map kindof TS KS,
  typapply PolyParamsT TS ParamsT,
  typeof Params ParamsT.

(* records *)
typeof (projrec E Field) T :-

  field_def Field PolyT Tbase,
  type_record_def Tbase KS _,
  map kindof TS KS,
  typapply TC TS T,
  once (typeof E (tbase Tbase TS)).

guess_type : map string A -> string -> prop.
guess_type ((Key, _) :: _) Tbase :-
  print "guessing!",
  field_def Key _ Tbase.

eqv X Y :- (nf X Z, nf Y Z).

typeof (record FieldsTerms) (tbase Tbase TS) :-

  guess_type FieldsTerms Tbase,
  type_record_def Tbase KS FieldsSpec,
  map kindof TS KS,

  map.mapvalues (fun a => typapply a TS) FieldsSpec FieldsTypes',
  eqv FieldsTypes FieldsTypes',
  map.mapvalues typeof FieldsTerms FieldsTypes.



(* matching. *)

typebranch   : typ -> typ -> bindmany term (patt * term) -> prop.
typeofpatt   : patt -> typ -> prop.


typeofpatt (pvar X) T :- typeof X T.

typeofpatt (ptuple PS) (tprod TS) :- map typeofpatt PS TS.

typeofpatt (pconstr C P) (tbase Tbase TS) :-

  constructor_def C (csdef PolyParamsT) Tbase,
  type_variant_def Tbase KS _,
  map kindof TS KS,

  typapply PolyParamsT TS T',
  typeofpatt P T'.

typeofpatt (pconstrun C) (tbase Tbase TS) :-

  constructor_def C csdefunit Tbase,
  type_variant_def Tbase KS _,
  map kindof TS KS.

typeofpatt pwild T.

typeofpatt (pas P P') T :- typeofpatt P T, typeofpatt P' T.

typeofpatt (precord FieldsPatts) (tbase Tbase TS) :-
  
  guess_type FP Tbase,
  type_record_def Tbase KS FieldsSpec,
  map.mapvalues typeofpatt FieldsPatts FieldsTypes,
  map kindof TS KS,
  map.mapvalues (fun a => typapply a TS) FieldsSpec FieldsTypes',
  eqv FieldsTypes FieldsTypes'.


typebranch T T' Branch :-
  bindmany.open Branch (pfun pattvars branch => [Patt Body]
    eq branch (Patt, Body),
    assume_many typeof pattvars TS {prop|
      typeofpatt Patt T,
      typeof Body T'
    |}).
  

typeof (match E Branches) T' :-
  typeof E T, not(refl.isunif T),
  map (typebranch T T') Branches.

typeof (match E Branches) T' :-
  typeof E T, not(refl.isunif T), nf T Tnf,
  map (typebranch Tnf T') Branches.

typeof (match E Branches) T' :-
  map (typebranch T T') Branches,
  typeof E T.

typeof (trycatch E Handlers) T :-
  typeof E T,
  map (typebranch (tbase "exn" []) T) Handlers.


(* conversion *)
(* TODO: move this in an otherwise block *)
(typeof X Tnf) when refl.isnvar X, once(typeof X T) :- nf T Tnf.
(typeof E T) when not (refl.isnvar E), not (refl.isunif T), once(typeof E T') :- nf T' Z, nf T Z.


(* ---------------------------- *)
(* module structures/signatures *)

stritem        : type.
sigitem        : type.


(* type definitions *)
typdef         : type.

typdef_variant : list (string * constrdef) -> typdef.
typdef_record  : list (string * typconstr) -> typdef.
typdef_eq      : typconstr -> typdef.

(* structure items *)
strlet    : string -> term -> stritem.
strlet_   : term -> stritem.
strletrec : bindmany term (list term) -> stritem.
strtype   : list string -> list (list knd) -> list typdef -> stritem.
strtypesingle : string -> list knd -> typdef -> stritem.
strexn    : string -> constrdef -> stritem.
strmany   : list stritem -> stritem.

(* signature items *)
sigval    : string -> typ -> sigitem.
sigtypedecl : string -> list knd -> sigitem.
sigtype   : list string -> list (list knd) -> list typdef -> sigitem.
sigexn    : string -> constrdef -> sigitem.
sigmany   : list sigitem -> sigitem.


(* signature of structure item *)

sigof : stritem -> sigitem -> prop.
sigitem_new_assumptions : sigitem -> list prop -> prop.
typdef_new_assumptions  : string -> list knd -> typdef -> list prop -> prop.

sigof (strlet Name E)
      (sigval Name T') :- typeof (let E (bind _ (fun y => y))) T, eqv T T'.

sigof (strlet_ E)
      (sigmany [])     :- typeof (let E (bind _ (fun y => y))) T.

sigof (strletrec ES)
      (sigmany Vals) :-
  bindmany.pair ES ESE' Both,
  bindmany.open Both (pfun xs (ES, ESE') => eq ESE' (ES, tuple xs)),
  bindmany.varnames ES Names,
  typeof (letrec ESE') (tprod TS),
  map (fun n t => eq (sigval n t)) Names TS Vals.


typdef_wf : typdef -> list knd -> prop.
typconstr_wf   : typconstr -> list knd -> prop.
constructor_wf : constrdef -> list knd -> prop.

typconstr_wf (typconstr TC) KS :-
  bindmany.open TC (fun ts t =>
    assume_many kindofg ts KS (kindof t ktype)
  ).

constructor_wf csdefunit KS.
constructor_wf (csdef TC) KS :- typconstr_wf TC KS.

typdef_wf (typdef_variant Constructors) KS :-
  map (pfun nc => [Name Constr] eq nc (Name, Constr), constructor_wf Constr KS ) Constructors.

typdef_wf (typdef_record Fields) KS :-
  map (pfun nc => [Name TConstr] eq nc (Name, TConstr), typconstr_wf TConstr KS ) Fields.

typdef_wf (typdef_eq TC) KS :-
  typconstr_wf TC KS.

sigof (strtype Names Arities Defs)
      (sigtype Names Arities Defs) :-
  
  map (fun ks => eq (karrow ks ktype)) Arities Kinds,
  assume_many kindofbase Names Kinds (map typdef_wf Defs Arities).

sigof (strtypesingle Name Arity Def) S' :- sigof (strtype [Name] [Arity] [Def]) S'.
      

sigof (strexn Name Constrdef) (sigexn Name Constrdef) :-
  constructor_wf Constrdef [].

sigof (strmany []) (sigmany []).
sigof (strmany (HD :: TL)) (sigmany (HDs :: TLs)) :-
  sigof HD HDs, sigitem_new_assumptions HDs Assum,
  assume_many Assum (sigof (strmany TL) (sigmany TLs)).

(* assumptions based on signature items *)

sigitem_new_assumptions (sigval Name T) [ named_gentypeof Name T ].

sigitem_new_assumptions (sigtypedecl Name Arity) [ kindofbase Name (karrow Arity ktype) ].

sigitem_new_assumptions (sigtype Names Arities Defs) Assumptions :-

  map (fun ks => eq (karrow ks ktype)) Arities Kinds,
  map (fun n k => eq (kindofbase n k)) Names Kinds Assume_Types,
  map typdef_new_assumptions Names Arities Defs Assume_Typdefs,
  concat (Assume_Types :: Assume_Typdefs) Assumptions.

sigitem_new_assumptions (sigexn Name Def) [ constructor_def Name Def "exn" ].

sigitem_new_assumptions (sigmany Sigs)  Flattened :-
  map sigitem_new_assumptions Sigs Assums,
  concat Assums Flattened.

typdef_new_assumptions TName KS (typdef_variant Constructors) ( (type_variant_def TName KS Constructors) ::
                                                                ConstrAssumptions ) :-

  map (pfun nc res => [Name Csdef] eq nc (Name, Csdef), eq res (constructor_def Name Csdef TName) )
      Constructors ConstrAssumptions.

typdef_new_assumptions TName KS (typdef_record Fields) ( (type_record_def TName KS Map) ::
                                                         FieldAssumptions ) :-
  map.from_list Fields Map,
  map (pfun nt res => [Name Tconstr] eq nt (Name, Tconstr), eq res (field_def Name Tconstr TName) )
      Fields FieldAssumptions.

typdef_new_assumptions TName KS (typdef_eq TypConstr) [ type_eq_def TName KS TypConstr ].


(* adding assumptions to global environment *)

ocamldo_sig : sigitem -> cmd -> prop.
ocamldo_sig S (cmd_many Cmds) :-
   sigitem_new_assumptions S Assumptions,
   map (fun g => eq (cmd_newclause (clause g success))) Assumptions Cmds.

ocamldo : stritem -> cmd -> prop.
ocamldo S C :- sigof S S', ocamldo_sig S' C.

(* ------------------------------------------------------------------------- *)


(* Built-in types *)

`( ocamldo_sig (sigtypedecl   "exn"  []) ).
type_variant_def "exn" [] ExnConstructors.

`( ocamldo_sig (sigtypedecl   "int"  []) ).
intconst : int -> term.
typeof (intconst N) (tbase "int" []).

`( ocamldo_sig (sigtypedecl   "string" []) ).
stringconst : string -> term.
typeof (stringconst S) (tbase "string" []).

`( ocamldo (strtypesingle "unit" [] (typdef_variant [ ( "Unit", csdefunit ) ])) ).
`( ocamldo (strtypesingle "list" [ktype] (typdef_variant
     [ ( "Nil", csdefunit ),
       ( "Cons", csdef (typconstr (bind "a" (fun a => body (tprod [ a, tbase "list" [a] ])))) ) ])) ).
`( ocamldo (strtypesingle "bool" [] (typdef_variant
     [ ( "True", csdefunit ),
       ( "False", csdefunit ) ])) ).

`( ocamldo (strtypesingle "option" [ktype] (typdef_variant
     [ ( "None", csdefunit ),
       ( "Some", csdef (typconstr (bind "a" (fun a => body a))) ) ])) ).
