src/HOL/Library/Tools/lazy.ML
author haftmann
Sun, 30 Mar 2025 13:50:06 +0200
changeset 82379 3f875966c3e1
permissions -rw-r--r--
optional external files as code modules
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
82379
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     1
(* Author: Pascal Stoop, ETH Zurich
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     2
   Author: Andreas Lochbihler, Digital Asset *)
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     3
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     4
signature LAZY =
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     5
sig
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     6
  type 'a lazy;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     7
  val lazy : (unit -> 'a) -> 'a lazy;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     8
  val force : 'a lazy -> 'a;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
     9
  val peek : 'a lazy -> 'a option
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    10
  val termify_lazy :
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    11
   (string -> 'typerep -> 'term) ->
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    12
   ('term -> 'term -> 'term) ->
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    13
   (string -> 'typerep -> 'term -> 'term) ->
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    14
   'typerep -> ('typerep -> 'typerep -> 'typerep) -> ('typerep -> 'typerep) ->
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    15
   ('a -> 'term) -> 'typerep -> 'a lazy -> 'term -> 'term;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    16
end;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    17
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    18
structure Lazy : LAZY =
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    19
struct
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    20
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    21
datatype 'a content =
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    22
   Delay of unit -> 'a
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    23
 | Value of 'a
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    24
 | Exn of exn;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    25
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    26
datatype 'a lazy = Lazy of 'a content ref;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    27
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    28
fun lazy f = Lazy (ref (Delay f));
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    29
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    30
fun force (Lazy x) = case !x of
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    31
   Delay f => (
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    32
     let val res = f (); val _ = x := Value res; in res end
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    33
     handle exn => (x := Exn exn; raise exn))
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    34
  | Value x => x
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    35
  | Exn exn => raise exn;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    36
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    37
fun peek (Lazy x) = case !x of
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    38
    Value x => SOME x
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    39
  | _ => NONE;
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    40
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    41
fun termify_lazy const app abs unitT funT lazyT term_of T x _ =
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    42
  app (const "Code_Lazy.delay" (funT (funT unitT T) (lazyT T)))
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    43
    (case peek x of SOME y => abs "_" unitT (term_of y)
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    44
     | _ => const "Pure.dummy_pattern" (funT unitT T));
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    45
3f875966c3e1 optional external files as code modules
haftmann
parents:
diff changeset
    46
end;