the commit continues with the support for validation (inactive for now)

[helm.git] / helm / software / helena / src / basic_rg / brgValidity.ml

diff --git a/helm/software/helena/src/basic_rg/brgValidity.ml b/helm/software/helena/src/basic_rg/brgValidity.ml
new file mode 100644 (file)
index 0000000..0fd2b8c
--- /dev/null
+++ b/helm/software/helena/src/basic_rg/brgValidity.ml
@@ -0,0 +1,91 @@
+(*
+    ||M||  This file is part of HELM, an Hypertextual, Electronic        
+    ||A||  Library of Mathematics, developed at the Computer Science     
+    ||T||  Department, University of Bologna, Italy.                     
+    ||I||                                                                
+    ||T||  HELM is free software; you can redistribute it and/or         
+    ||A||  modify it under the terms of the GNU General Public License   
+    \   /  version 2 or (at your option) any later version.              
+     \ /   This software is distributed as is, NO WARRANTY.              
+      V_______________________________________________________________ *)
+
+module L  = Log
+module E  = Entity
+module B  = Brg
+module BE = BrgEnvironment
+module BR = BrgReduction
+
+(* Internal functions *******************************************************)
+
+let level = 4
+
+let message1 st1 m t1 =
+   L.et_items1 "In the environment" m st1 t1
+
+let log1 s m t =
+   let s =  s ^ " the term" in
+   L.log BR.specs level (message1 s m t) 
+
+let error1 err s m t =
+   err (message1 s m t)
+
+let message2 m1 t1 m2 t2 =    
+   let sm2, st2 = "In the environment", "the term" in
+   let sm1, st1 = "is valid, but in the environment", "it must be of type" in
+   L.et_items2 sm2 m2 st2 t2 ~sc2:sm1 ~c2:m1 st1 t1
+
+let error2 err m1 t1 m2 t2 =
+   err (message2 m1 t1 m2 t2)
+
+let assert_convertibility err f st m u t =
+   if BR.are_convertible st m (Some 0) u m (Some 1) t then f () else
+   error2 err m u m t
+
+let assert_applicability err f st m v t =
+   match BR.xwhd st m None t with 
+      | _, B.Sort _                      ->
+         error1 err "not a function" m t
+      | mw, B.Bind (_, B.Abst (_, w), _) ->
+         if BR.are_convertible st mw (Some 0) w m (Some 1) v then f () else
+        error2 err mw w m v
+      | _                                -> assert false (**)
+
+let rec b_validate err f st m x =
+   log1 "Now checking" m x;
+   match x with
+   | B.Sort _         -> f ()
+   | B.LRef (_, i)    ->
+      begin match BR.get m i with
+         | B.Abst _
+        | B.Abbr _ -> f ()
+        | B.Void   -> 
+           error1 err "reference to excluded variable" m x
+      end
+   | B.GRef (_, uri)  ->
+      begin match BE.get_entity uri with
+         | _, _, E.Abst _
+        | _, _, E.Abbr _ -> f ()
+        | _, _, E.Void   ->
+            error1 err "reference to unknown entry" m x
+      end
+   | B.Bind (a, b, t) ->
+      let f () = b_validate err f st (BR.push m a b) t in
+      begin match b with 
+         | B.Abst (n, u) -> validate err f st m u
+         | B.Abbr v      -> validate err f st m v
+         | B.Void        -> f ()
+      end
+   | B.Appl (_, v, t)        ->
+      let f () = assert_applicability err f st m v t in
+      let f () = b_validate err f st m t in
+      validate err f st m v
+   | B.Cast (_, u, t)        ->
+      let f () = assert_convertibility err f st m u t in
+      let f () = b_validate err f st m t in
+      validate err f st m u
+
+(* Interface functions ******************************************************)
+
+and validate err f st m x =
+   let f () = L.unbox level; f () in
+   L.box level; b_validate err f st m x