├── .gitignore ├── .gitmodules ├── .travis.yml ├── README.md ├── dependent_lcf.cm ├── dependent_lcf.mlb ├── development.cm ├── example.sml ├── lcf_abt.cm ├── lcf_abt.mlb ├── lib ├── cmlib.cm └── cmlib.mlb ├── scripts └── mlton.sh ├── sml.json └── src ├── abt └── language.fun └── dependent_lcf ├── language.sig ├── lcf.fun ├── lcf.sig ├── logic.sig ├── logic.sml ├── tactic.fun └── tactic.sig /.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | *.aux 3 | *.log 4 | *.out 5 | *.agdai 6 | dependent_lcf 7 | !dependent_lcf/ 8 | nominal_lcf 9 | !nominal_lcf/ 10 | lcf_abt 11 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "lib/sml-telescopes"] 2 | path = lib/sml-telescopes 3 | url = https://github.com/jonsterling/sml-telescopes.git 4 | [submodule "lib/cmlib"] 5 | path = lib/cmlib 6 | url = https://github.com/standardml/cmlib.git 7 | [submodule "lib/sml-typed-abts"] 8 | path = lib/sml-typed-abts 9 | url = https://github.com/JonPRL/sml-typed-abts 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: sml 2 | before_install: 3 | - sudo apt-get update -qq 4 | - sudo apt-get install -y --force-yes mlton 5 | install: 6 | - git submodule init 7 | - git submodule update --init --recursive 8 | script: 9 | - ./scripts/mlton.sh 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repository contains a library for building tactic-based refiners in the LCF and Nuprl tradition. 2 | 3 | ### Dependent LCF: modernized refinement proof 4 | 5 | Dependent LCF is a modernization of the old LCF tactic system, to deal with 6 | dependent refinement properly. A proof state is a telescope of judgments, where 7 | each judgment binds a metavariable in the rest of the telescope, together with 8 | a term that takes its free metavariables from the telescope. 9 | 10 | The telescope corresponds to the list of subgoals in LCF, and the open term 11 | corresponds to the "validation" in LCF. Whereas in Classic LCF, the validation 12 | was a computational function from evidence to evidence, here it is a piece of 13 | evidence with free variables; this design choice is forced by the categorical 14 | semantics for Dependent LCF, and suggests that the computational character of 15 | validations in Classic LCF is a design which does not generalize cleanly. 16 | 17 | ### Instructions 18 | 19 | ``` 20 | git submodule update --init --recursive 21 | rlwrap sml 22 | > CM.make "development.cm"; 23 | ``` 24 | -------------------------------------------------------------------------------- /dependent_lcf.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature LCF_VAR 3 | signature LCF_LANGUAGE 4 | 5 | signature LCF 6 | signature LCF_JUDGMENT 7 | signature LCF_TACTIC 8 | signature LCF_TRACE 9 | signature LCF_INFO 10 | 11 | functor TracedLcf 12 | functor PlainLcf 13 | functor Lcf 14 | functor LcfListTrace 15 | signature LCF_TACTIC_MONAD 16 | signature LCF_TACTIC_KIT 17 | functor LcfTactic 18 | structure LcfMonadBT 19 | is 20 | $/basis.cm 21 | $libs/sml-telescopes/telescopes.cm 22 | lib/cmlib.cm 23 | src/dependent_lcf/language.sig 24 | src/dependent_lcf/lcf.sig 25 | src/dependent_lcf/lcf.fun 26 | src/dependent_lcf/tactic.sig 27 | src/dependent_lcf/tactic.fun 28 | src/dependent_lcf/logic.sig 29 | src/dependent_lcf/logic.sml 30 | 31 | 32 | -------------------------------------------------------------------------------- /dependent_lcf.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | lib/cmlib.mlb 4 | $(LIBS)/sml-telescopes/telescopes.mlb 5 | src/dependent_lcf/language.sig 6 | src/dependent_lcf/lcf.sig 7 | src/dependent_lcf/lcf.fun 8 | src/dependent_lcf/tactic.sig 9 | src/dependent_lcf/logic.sig 10 | src/dependent_lcf/logic.sml 11 | src/dependent_lcf/tactic.fun 12 | in 13 | signature LCF_VAR 14 | signature LCF_LANGUAGE 15 | 16 | signature LCF 17 | signature LCF_JUDGMENT 18 | signature LCF_TACTIC 19 | signature LCF_TRACE 20 | signature LCF_INFO 21 | 22 | functor TracedLcf 23 | functor Lcf 24 | functor LcfListTrace 25 | signature LCF_TACTIC_MONAD 26 | signature LCF_TACTIC_KIT 27 | functor LcfTactic 28 | structure LcfMonadBT 29 | end 30 | -------------------------------------------------------------------------------- /development.cm: -------------------------------------------------------------------------------- 1 | Group 2 | is 3 | $/basis.cm 4 | lib/cmlib.cm (bind:(anchor:libs value:lib)) 5 | lib/sml-typed-abts/abt.cm (bind:(anchor:libs value:lib)) 6 | lib/sml-telescopes/telescopes.cm (bind:(anchor:libs value:lib)) 7 | dependent_lcf.cm (bind:(anchor:libs value:lib)) 8 | lcf_abt.cm (bind:(anchor:libs value:lib)) 9 | example.sml 10 | -------------------------------------------------------------------------------- /example.sml: -------------------------------------------------------------------------------- 1 | structure Sort : ABT_SORT = 2 | struct 3 | type t = unit 4 | val eq : t * t -> bool = op= 5 | fun toString () = "exp" 6 | end 7 | 8 | structure Vl = AbtValence (structure S = Sort) 9 | structure Ar = AbtArity (Vl) 10 | 11 | structure L = 12 | struct 13 | structure Ar = Ar 14 | 15 | datatype t = 16 | UNIT 17 | | SIGMA 18 | | AX 19 | | PAIR 20 | | FOO (* a dummy proposition to demonstrate dependency *) 21 | 22 | val eq = op= 23 | 24 | fun arity UNIT = ([], ()) 25 | | arity SIGMA = ([([],()), ([()], ())], ()) 26 | | arity AX = ([], ()) 27 | | arity PAIR = ([([],()), ([], ())], ()) 28 | | arity FOO = ([([],()), ([], ())], ()) 29 | 30 | fun toString UNIT = "Unit" 31 | | toString SIGMA = "Σ" 32 | | toString AX = "Ax" 33 | | toString PAIR = "Pair" 34 | | toString FOO = "Foo" 35 | end 36 | 37 | structure Term = SimpleAbt (L) 38 | structure ShowTm = DebugShowAbt (Term) 39 | 40 | structure Language = LcfAbtLanguage (Term) 41 | 42 | structure Judgment = 43 | struct 44 | structure Tm = Term 45 | 46 | type sort = Language.sort 47 | type env = Language.env 48 | type ren = Language.ren 49 | 50 | datatype jdg = TRUE of Tm.abt 51 | 52 | fun toString (TRUE p) = 53 | ShowTm.toString p ^ " true" 54 | 55 | fun sort _ = 56 | ([], ()) 57 | 58 | fun eq (TRUE m, TRUE n) = Tm.eq (m, n) 59 | fun subst env (TRUE m) = TRUE (Tm.substMetaenv env m) 60 | fun ren env (TRUE m) = TRUE (Tm.renameMetavars env m) 61 | end 62 | 63 | structure Lcf = TracedLcf (structure L = Language and Tr = LcfListTrace (type e = string)) 64 | structure Tac = LcfTactic (structure Lcf = Lcf and J = Judgment and M = LcfMonadBT) 65 | 66 | 67 | signature REFINER = 68 | sig 69 | val UnitIntro : Tac.jdg Tac.rule 70 | val SigmaIntro : Tac.jdg Tac.rule 71 | val FooIntro : Tac.jdg Tac.rule 72 | end 73 | 74 | structure Refiner :> REFINER = 75 | struct 76 | open Judgment Term 77 | infix $ $$ $# \ 78 | structure Tl = Lcf.Tl and V = Term.Metavar 79 | 80 | val |> = Lcf.|> 81 | val ::@ = Lcf.::@ 82 | infix 2 ::@ 83 | infix 3 |> 84 | 85 | local structure Notation = TelescopeNotation (Tl) in open Notation infix 4 >: end 86 | 87 | local 88 | val i = ref 0 89 | fun newMeta () = 90 | (i := !i + 1; 91 | V.named (Int.toString (!i))) 92 | in 93 | fun makeGoal jdg = 94 | let 95 | val x = newMeta () 96 | in 97 | ((x, jdg), fn ms => check (x $# ms, ())) 98 | end 99 | end 100 | 101 | fun UnitIntro (TRUE P) = 102 | let 103 | val L.UNIT $ [] = out P 104 | val ax = L.AX $$ [] 105 | in 106 | Tl.empty |> abtToAbs ax 107 | end 108 | 109 | fun SigmaIntro (TRUE P) = 110 | let 111 | val L.SIGMA $ [_ \ A, [x] \ B] = out P 112 | val (goalA, holeA) = makeGoal (["SigmaI/proj1"] ::@ TRUE A) 113 | val (goalB, holeB) = makeGoal (["SigmaI/proj2"] ::@ TRUE (substVar (holeA [], x) B)) 114 | val pair = L.PAIR $$ [[] \ holeA [], [] \ holeB []] 115 | in 116 | Tl.empty >: goalA >: goalB 117 | |> abtToAbs pair 118 | end 119 | 120 | fun FooIntro (TRUE P) = 121 | let 122 | val L.FOO $ [_ \ A, _] = out P 123 | val (goalA, holeA) = makeGoal (["FooI"] ::@ TRUE A) 124 | in 125 | Tl.empty >: goalA |> abtToAbs (holeA []) 126 | end 127 | end 128 | 129 | structure Example = 130 | struct 131 | open L Refiner Judgment 132 | open Tac Lcf Term 133 | structure ShowTm = PlainShowAbt (Term) 134 | structure ShowTel = TelescopeUtil (Tl) 135 | infix 5 $ \ then_ orelse_ 136 | 137 | val x = Var.named "x" 138 | 139 | val subgoalsToString = 140 | ShowTel.toString (fn (TRUE p) => ShowTm.toString p ^ " true") 141 | 142 | fun run goal (tac : jdg tactic) = 143 | let 144 | val Lcf.|> (psi, vld) = Tac.M.run (tac goal, fn _ => true) 145 | val xs \ m = outb vld 146 | fun prettyGoal (Lcf.::@ (i, jdg)) = 147 | "{[" ^ List.foldr (fn (x, s) => x ^ "." ^ s) "" i ^ "] @ " ^ 148 | Judgment.toString jdg 149 | ^ "}" 150 | in 151 | print "\n\n"; 152 | print (ShowTel.toString prettyGoal psi); 153 | print "\n--------------------------------\n"; 154 | print (ShowTm.toString m); 155 | print "\n\n" 156 | end 157 | 158 | val mkUnit = check (UNIT $ [], ()) 159 | fun mkSigma x a b = check (SIGMA $ [[] \ a, [x] \ b], ()) 160 | fun mkFoo a b = check (FOO $ [[] \ a, [] \ b], ()) 161 | 162 | val x = Var.named "x" 163 | val y = Var.named "y" 164 | 165 | val goal = 166 | mkSigma y 167 | (mkSigma x mkUnit mkUnit) 168 | (mkFoo mkUnit (check (`y, ()))) 169 | 170 | (* to interact with the refiner, try commenting out some of the following lines *) 171 | val script = 172 | Tac.rule SigmaIntro 173 | then_ try (Tac.rule SigmaIntro) 174 | then_ try (Tac.rule UnitIntro) 175 | then_ Tac.rule FooIntro 176 | then_ Tac.rule UnitIntro 177 | 178 | 179 | val _ = run (TRUE goal) script 180 | end 181 | -------------------------------------------------------------------------------- /lcf_abt.cm: -------------------------------------------------------------------------------- 1 | Library 2 | functor LcfAbtLanguage 3 | is 4 | $/basis.cm 5 | lib/cmlib.cm 6 | $libs/sml-typed-abts/abt.cm 7 | $libs/sml-telescopes/telescopes.cm 8 | dependent_lcf.cm 9 | src/abt/language.fun 10 | -------------------------------------------------------------------------------- /lcf_abt.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | lib/cmlib.mlb 4 | $(LIBS)/sml-typed-abts/abt.mlb 5 | $(LIBS)/sml-telescopes/telescopes.mlb 6 | dependent_lcf.mlb 7 | src/abt/language.fun 8 | in 9 | functor LcfAbtLanguage 10 | end 11 | 12 | -------------------------------------------------------------------------------- /lib/cmlib.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature ORDERED 3 | signature DICT 4 | is 5 | $libs/cmlib/cmlib.cm -------------------------------------------------------------------------------- /lib/cmlib.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(LIBS)/cmlib/cmlib.mlb 3 | in 4 | signature ORDERED 5 | signature DICT 6 | end -------------------------------------------------------------------------------- /scripts/mlton.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | LIBS=$(pwd)/lib 4 | 5 | mlton -mlb-path-var "LIBS $LIBS" dependent_lcf.mlb 6 | mlton -mlb-path-var "LIBS $LIBS" lcf_abt.mlb 7 | -------------------------------------------------------------------------------- /sml.json: -------------------------------------------------------------------------------- 1 | { 2 | "cm": { 3 | "make/onSave": "development.cm" 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /src/abt/language.fun: -------------------------------------------------------------------------------- 1 | functor FreshSymbols (S : ABT_SYMBOL) = 2 | struct 3 | fun freshSyms ss = 4 | let 5 | fun go i ctx [] = [] 6 | | go i ctx (s :: ss) = 7 | let 8 | val u = S.fresh ctx ("?" ^ Int.toString i) 9 | in 10 | (u, s) :: go (i + 1) (S.Ctx.insert ctx u ()) ss 11 | end 12 | in 13 | go 0 S.Ctx.empty ss 14 | end 15 | end 16 | 17 | signature LCF_ABT_LANGUAGE = 18 | sig 19 | structure Abt : ABT 20 | include LCF_LANGUAGE 21 | where type sort = Abt.valence 22 | where type Var.t = Abt.Metavar.t 23 | where type 'a Ctx.dict = 'a Abt.Metavar.Ctx.dict 24 | where type term = Abt.abs 25 | end 26 | 27 | functor LcfAbtLanguage (Abt : ABT) : LCF_ABT_LANGUAGE = 28 | struct 29 | structure Abt = Abt 30 | structure Var = Abt.Metavar 31 | structure Ctx = Abt.Metavar.Ctx 32 | type sort = Abt.valence 33 | type var = Var.t 34 | type term = Abt.abs 35 | type ctx = sort Ctx.dict 36 | type env = term Ctx.dict 37 | type ren = var Ctx.dict 38 | 39 | local 40 | val counter = ref 0 41 | in 42 | fun fresh () = 43 | (counter := !counter + 1; 44 | Var.named (Int.toString (!counter))) 45 | end 46 | 47 | local 48 | structure FreshVars = FreshSymbols (Abt.Var) 49 | in 50 | fun var v vl = 51 | Abt.metavar (v, vl) 52 | end 53 | 54 | val subst = Abt.mapAbs o Abt.substMetaenv 55 | val ren = Abt.mapAbs o Abt.renameMetavars 56 | val eq = Abt.eqAbs 57 | end 58 | -------------------------------------------------------------------------------- /src/dependent_lcf/language.sig: -------------------------------------------------------------------------------- 1 | signature LCF_VAR = 2 | sig 3 | include ORDERED 4 | val toString : t -> string 5 | end 6 | 7 | signature LCF_LANGUAGE = 8 | sig 9 | structure Var : LCF_VAR 10 | structure Ctx : DICT 11 | sharing type Var.t = Ctx.key 12 | 13 | type sort 14 | type term 15 | type var = Var.t 16 | type ctx = sort Ctx.dict 17 | type env = term Ctx.dict 18 | type ren = var Ctx.dict 19 | 20 | val fresh : unit -> var 21 | val var : var -> sort -> term 22 | val subst : env -> term -> term 23 | val ren : ren -> term -> term 24 | val eq : term * term -> bool 25 | end 26 | -------------------------------------------------------------------------------- /src/dependent_lcf/lcf.fun: -------------------------------------------------------------------------------- 1 | functor Lcf (structure L : LCF_LANGUAGE and I : LCF_INFO) : LCF = 2 | struct 3 | structure L = L and Tl = Telescope (L.Var) and I = I 4 | datatype 'a state = |> of 'a I.t Tl.telescope * L.term 5 | 6 | infix 3 |> 7 | 8 | type 'a isjdg = 9 | {sort : 'a -> L.sort, 10 | subst : L.env -> 'a -> 'a, 11 | ren : L.ren -> 'a -> 'a} 12 | 13 | fun liftJdg isjdg = isjdg 14 | 15 | fun map f (psi |> m) = 16 | Tl.map (I.map f) psi |> m 17 | 18 | fun ret {sort, subst, ren} (a : 'a) = 19 | let 20 | val x = L.fresh () 21 | in 22 | Tl.singleton x (I.ret a) |> L.var x (sort a) 23 | end 24 | 25 | fun 'a mul {sort, subst, ren} = 26 | let 27 | open Tl.ConsView 28 | 29 | fun go (psi : 'a I.t telescope, m : L.term, env : L.env, ppsi : 'a state I.t telescope) = 30 | case out ppsi of 31 | EMPTY => psi |> L.subst env m 32 | | CONS (x, stx, ppsi') => 33 | let 34 | val psix |> mx = I.run stx 35 | val psix' = Tl.map (fn jdg => I.bind (stx, fn _ => I.map (subst env) jdg)) psix 36 | val psi' = Tl.append psi psix' 37 | val env' = L.Ctx.insert env x mx 38 | in 39 | go (psi', m, env', ppsi') 40 | end 41 | in 42 | fn (psi |> m) => 43 | go (Tl.empty, m, L.Ctx.empty, psi) 44 | end 45 | end 46 | 47 | functor LcfListTrace (type e) : LCF_TRACE = 48 | struct 49 | type t = e list 50 | val empty = [] 51 | val append = op@ 52 | end 53 | 54 | functor LcfTraceInfo (Tr : LCF_TRACE) : 55 | sig 56 | datatype 'a traced = ::@ of Tr.t * 'a 57 | include LCF_INFO where type 'a t = 'a traced 58 | end = 59 | struct 60 | datatype 'a traced = ::@ of Tr.t * 'a 61 | type 'a t = 'a traced 62 | 63 | infix ::@ 64 | 65 | fun ret a = 66 | Tr.empty ::@ a 67 | 68 | fun run (_ ::@ a) = 69 | a 70 | 71 | fun map f (t ::@ a) = 72 | t ::@ f a 73 | 74 | fun replace a (t ::@ _) = 75 | t ::@ a 76 | 77 | fun bind (t ::@ a, k) = 78 | let 79 | val t' ::@ b = k a 80 | in 81 | Tr.append (t, t') ::@ b 82 | end 83 | end 84 | 85 | structure LcfIdentityInfo : LCF_INFO = 86 | struct 87 | type 'a t = 'a 88 | fun ret a = a 89 | fun run a = a 90 | fun map f = f 91 | fun bind (a, k) = k a 92 | fun replace a _ = a 93 | end 94 | 95 | functor PlainLcf (L : LCF_LANGUAGE) : PLAIN_LCF = Lcf (structure L = L and I = LcfIdentityInfo) 96 | 97 | functor TracedLcf (structure L : LCF_LANGUAGE and Tr : LCF_TRACE) : TRACED_LCF = 98 | struct 99 | local 100 | structure TrI = LcfTraceInfo (Tr) 101 | structure X = Lcf (structure L = L and I = TrI) 102 | in 103 | open X 104 | type trace = Tr.t 105 | datatype traced = datatype TrI.traced 106 | end 107 | end 108 | -------------------------------------------------------------------------------- /src/dependent_lcf/lcf.sig: -------------------------------------------------------------------------------- 1 | signature LCF_TRACE = 2 | sig 3 | type t 4 | val empty : t 5 | val append : t * t -> t 6 | end 7 | 8 | signature LCF_INFO = 9 | sig 10 | type 'a t 11 | val ret : 'a -> 'a t 12 | val run : 'a t -> 'a 13 | val map : ('a -> 'b) -> 'a t -> 'b t 14 | val bind : 'a t * ('a -> 'b t) -> 'b t 15 | val replace : 'b -> 'a t -> 'b t 16 | end 17 | 18 | signature LCF = 19 | sig 20 | structure L : LCF_LANGUAGE 21 | structure Tl : TELESCOPE where type Label.t = L.var 22 | structure I : LCF_INFO 23 | 24 | datatype 'a state = |> of 'a I.t Tl.telescope * L.term 25 | 26 | type 'a isjdg = 27 | {sort : 'a -> L.sort, 28 | subst : L.env -> 'a -> 'a, 29 | ren : L.ren -> 'a -> 'a} 30 | 31 | val map : ('a -> 'b) -> 'a state -> 'b state 32 | val ret : 'a isjdg -> 'a -> 'a state 33 | val mul : 'a isjdg -> 'a state state -> 'a state 34 | end 35 | 36 | signature PLAIN_LCF = 37 | LCF where type 'a I.t = 'a 38 | 39 | signature TRACED_LCF = 40 | sig 41 | type trace 42 | datatype 'a traced = ::@ of trace * 'a 43 | include LCF where type 'a I.t = 'a traced 44 | end 45 | 46 | signature LCF_JUDGMENT = 47 | sig 48 | type jdg 49 | type sort 50 | type env 51 | type ren 52 | 53 | val sort : jdg -> sort 54 | val subst : env -> jdg -> jdg 55 | val ren : ren -> jdg -> jdg 56 | val eq : jdg * jdg -> bool 57 | end 58 | -------------------------------------------------------------------------------- /src/dependent_lcf/logic.sig: -------------------------------------------------------------------------------- 1 | (* By Daniel Gratzer *) 2 | 3 | signature LOGIC = 4 | sig 5 | (* The core type of this library, a potentially infinite stream of 6 | * values of type 'a. This is left abstract so the only way to 7 | * construct one of these is with the helpful functions below. 8 | *) 9 | type 'a t 10 | 11 | (* map f t applies a function f to every element in t. 12 | * Note that since [t] may contain elements which haven't 13 | * been evaluated, there is no guarantee when or if [f] will 14 | * be run on all the elements of the list. EG, 15 | * 16 | * map print (delay (fn () => return "Hello World")) 17 | * 18 | * Needn't print anything, but would if we ever used [observe] 19 | * or friends. 20 | *) 21 | val map : ('a -> 'b) -> 'a t -> 'b t 22 | 23 | (* The empty sequence containing no elements *) 24 | val empty : 'a t 25 | 26 | (* Combine two sequences. The nice part of this function is that 27 | * any element which has a finite index in either sequence will have 28 | * a finite element in the output stream. 29 | *) 30 | val merge : 'a t -> 'a t -> 'a t 31 | 32 | (* Convert a list to a stream so that [toList o fromList] 33 | * is id 34 | *) 35 | val fromList : 'a list -> 'a t 36 | 37 | (* When tying knots in ML, it's necessary to introduce a lambda in 38 | * order to do so. This function facilitates that. EG 39 | * 40 | * val fives = merge (return 5) fives 41 | * 42 | * will diverge but 43 | * 44 | * fun fives () = merge (return 5) (delay fives) 45 | * val fives = fives () 46 | * 47 | * Will work as expected. 48 | *) 49 | val delay : (unit -> 'a t) -> 'a t 50 | 51 | (* Fair-sharing version of >>=. This behaves a lot like 52 | * mapping a function over a stream and then @-ing the results. 53 | * 54 | * However, it does this in such a way that if any component is finitely 55 | * reachable in any of the resulting ['b t]'s, it has a finite index 56 | * in the output. 57 | * 58 | * However, since merging doesn't preserve order, it isn't the case that 59 | * >>- follows the monad laws. If you're viewing 'a t as a nondeterministic 60 | * computation anyways, then this is fine. Otherwise, you can use >>= 61 | * proper. 62 | *) 63 | val >>- : 'a t * ('a -> 'b t) -> 'b t 64 | 65 | (* This will follow the monad laws together with [return]. It behaves 66 | * exactly like mapping a function over a stream and then appending the 67 | * results. 68 | * 69 | * However unlike >>- it's not guarenteed that all finitely reachable 70 | * elements in results of the function supplied will have a finite index 71 | * in the final stream. 72 | *) 73 | val >>= : 'a t * ('a -> 'b t) -> 'b t 74 | 75 | val shortcircuit : 'a t * ('a -> bool) * ('a -> 'b t) -> 'b t 76 | 77 | (* Creates a stream with a single element in it. *) 78 | val return : 'a -> 'a t 79 | 80 | (* The canonical unfolding operator streams should give rise to. 81 | * The idea is that you supply a seed and an unfolding operation. 82 | * unfold will create a stream by applying the seed to the supplied 83 | * function. 84 | * 85 | * - If NONE is returned it returns empty and halts 86 | * - If SOME (a, b') is returned, it returns a stream with 87 | * a at the head whose tail lazily computes [unfold f b'] 88 | * 89 | * This can be used to create potentially infinite streams quite 90 | * easily. 91 | *) 92 | val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t 93 | 94 | (* A nice convience for treating streams as nondeterministic computations. 95 | * [ifte i t e] behaves thusly 96 | * 97 | * If [i] contains at least one element (succeeds at all) then we will 98 | * return [i >>- t], otherwise, we will return e. This means that the 99 | * results of t and e will *never* show up in the results together. 100 | *) 101 | val ifte : 'a t -> ('a -> 'b t) -> 'b t -> 'b t 102 | 103 | (* This truncates a stream so that it only contains one element. 104 | * This is useful it is being handled as a nondeterministic computation 105 | * and we're only interested in using one of its results. 106 | *) 107 | val once : 'a t -> 'a t 108 | 109 | (* This behaves like a safe version of hd and tl for streams. It will 110 | * return the first element of a stream and the tail of it *if* the stream 111 | * is non-empty. Otherwise, it will just return NONE 112 | * 113 | * This should always terminate for stream values unless one has improperly 114 | * used [delay] and created a stream which is just an infinite stack of 115 | * [delay]s. For example [fun bad () = delay bad] 116 | *) 117 | val uncons : 'a t -> ('a * 'a t) option 118 | 119 | (* This has similar properties to uncons but just returns a finite prefix 120 | * of a stream, raising Empty if there aren't enough elements 121 | *) 122 | exception Empty 123 | val observe : int -> 'a t -> 'a list 124 | 125 | (* [toList s] will terminate with a list containing the elements of s 126 | * if s is finite, otherwise it will loop forever 127 | *) 128 | val toList : 'a t -> 'a list 129 | end -------------------------------------------------------------------------------- /src/dependent_lcf/logic.sml: -------------------------------------------------------------------------------- 1 | structure Logic :> LOGIC = 2 | struct 3 | datatype 'a t 4 | = CONS of 'a * 'a t 5 | | PAUSE of unit -> 'a t 6 | | NIL 7 | 8 | val empty = NIL 9 | val delay = PAUSE 10 | 11 | fun uncons s = 12 | case s of 13 | NIL => NONE 14 | | CONS (a, t) => SOME (a, t) 15 | | PAUSE p => uncons (p ()) 16 | 17 | exception Empty 18 | fun observe 0 s = [] 19 | | observe i s = 20 | 21 | case uncons s of 22 | NONE => raise Empty 23 | | SOME (a, s') => a :: observe (i - 1) s' 24 | 25 | fun toList s = 26 | case s of 27 | NIL => [] 28 | | CONS (a, s') => a :: toList s' 29 | | PAUSE p => toList (p ()) 30 | 31 | fun map f s = 32 | case s of 33 | NIL => NIL 34 | | CONS (a, t) => CONS (f a, map f t) 35 | | PAUSE p => PAUSE (fn () => map f (p ())) 36 | 37 | fun merge l r = 38 | case l of 39 | NIL => r 40 | | CONS (a, l') => CONS (a, merge l' r) 41 | | PAUSE p => PAUSE (fn () => merge r (p ())) 42 | 43 | fun return a = CONS (a, NIL) 44 | fun >>- (s, f) = 45 | case s of 46 | NIL => NIL 47 | | CONS (a, s') => merge (f a) (>>- (s', f)) 48 | | PAUSE p => PAUSE (fn () => >>- (p (), f)) 49 | 50 | fun shortcircuit (s, p, f) = 51 | case s of 52 | NIL => NIL 53 | | CONS (a, s') => if p a then f a else merge (f a) (shortcircuit (s', p, f)) 54 | | PAUSE s' => PAUSE (fn () => shortcircuit (s' (), p, f)) 55 | 56 | infixr 1 >>- 57 | 58 | fun >>= (s, f) = 59 | let 60 | fun concat ss = 61 | case ss of 62 | NIL => NIL 63 | | PAUSE p => PAUSE (fn () => concat (p ())) 64 | | CONS (NIL, ss') => concat ss' 65 | | CONS (CONS (a, s), ss') => CONS (a, concat (CONS (s, ss'))) 66 | | CONS (PAUSE p, ss') => 67 | PAUSE (fn () => concat (CONS (p (), ss'))) 68 | in 69 | concat (map f s) 70 | end 71 | 72 | fun unfold f b = 73 | case f b of 74 | NONE => NIL 75 | | SOME (a, b') => 76 | CONS (a, PAUSE (fn () => unfold f b')) 77 | 78 | fun fromList xs = 79 | List.foldl (fn (a, b) => merge a b) 80 | NIL 81 | (List.map return xs) 82 | 83 | fun ifte i t e = 84 | case uncons i of 85 | NONE => e 86 | | SOME (a, b) => CONS (a, b) >>- t 87 | 88 | fun once s = 89 | case uncons s of 90 | NONE => NIL 91 | | SOME (a, _) => return a 92 | end -------------------------------------------------------------------------------- /src/dependent_lcf/tactic.fun: -------------------------------------------------------------------------------- 1 | signature LCF_TACTIC_KIT = 2 | sig 3 | structure Lcf : LCF 4 | structure J : LCF_JUDGMENT 5 | where type sort = Lcf.L.sort 6 | where type env = Lcf.L.term Lcf.L.Ctx.dict 7 | where type ren = Lcf.L.var Lcf.L.Ctx.dict 8 | end 9 | 10 | structure LcfMonadBT : 11 | sig 12 | include LCF_TACTIC_MONAD 13 | exception Refine of exn list 14 | end = 15 | struct 16 | datatype 'a result = 17 | OK of 'a 18 | | ERR of exn 19 | 20 | type 'a m = 'a result Logic.t 21 | 22 | exception Refine of exn list 23 | 24 | local 25 | fun runAux p exns m = 26 | case Logic.uncons m of 27 | SOME (OK r, t) => if p r then r else runAux p exns t 28 | | SOME (ERR exn, t) => runAux p (exn :: exns) t 29 | | NONE => raise Refine exns 30 | in 31 | fun run (m, p) = runAux p [] m 32 | end 33 | 34 | fun throw exn = Logic.return (ERR exn) 35 | fun par (m1, m2) = Logic.merge m1 m2 36 | fun or (m1, m2) = 37 | case Logic.uncons m1 of 38 | SOME (OK a, _) => m1 39 | | SOME (ERR _, m1') => or (m1', m2) 40 | | NONE => m2 41 | 42 | fun map (f : 'a -> 'b) (m : 'a m) = Logic.map (fn OK a => OK (f a) | ERR exn => ERR exn) m 43 | fun mapErr f = Logic.map (fn OK a => OK a | ERR exn => ERR (f exn)) 44 | fun ret (a : 'a) : 'a m = Logic.return (OK a) 45 | fun bind (m, f) = Logic.>>- (m, fn OK a => f a | ERR exn => Logic.return (ERR exn)) 46 | fun mul mm = bind (mm, fn x => x) 47 | fun shortcircuit (m, p, f) = 48 | Logic.shortcircuit 49 | (m, fn OK x => p x | ERR _ => false, fn OK a => f a | ERR exn => Logic.return (ERR exn)) 50 | end 51 | 52 | functor LcfTactic (include LCF_TACTIC_KIT structure M : LCF_TACTIC_MONAD) : LCF_TACTIC = 53 | struct 54 | open Lcf 55 | structure M = M and J = J 56 | 57 | infix 2 ::@ 58 | infix 3 |> 59 | 60 | type jdg = J.jdg 61 | 62 | type 'a rule = 'a -> 'a state 63 | type 'a tactic = 'a -> 'a state M.m 64 | type 'a multitactic = 'a state tactic 65 | 66 | val isjdg : jdg isjdg = 67 | {sort = J.sort, 68 | subst = J.subst, 69 | ren = J.ren} 70 | 71 | fun @@ (f, x) = f x 72 | infix @@ 73 | 74 | fun wrap (t : 'a tactic) : 'a tactic = fn jdg => 75 | t jdg handle exn => M.throw exn 76 | 77 | fun rule r jdg = 78 | M.ret (r jdg) 79 | handle exn => M.throw exn 80 | 81 | val idn = M.ret o ret isjdg 82 | 83 | fun >>-* (m : 'a state M.m, k : 'a state -> 'b M.m) : 'b M.m = 84 | M.shortcircuit (m, fn psi |> _ => Tl.isEmpty psi, k) 85 | 86 | infix >>-* 87 | 88 | fun each (ts : jdg tactic list) (psi |> vl) : jdg state state M.m = 89 | let 90 | open Tl.ConsView 91 | fun go (r : jdg state I.t telescope) = 92 | fn (_, EMPTY) => M.ret r 93 | | (t :: ts, CONS (x, jdg, psi)) => 94 | wrap t (I.run jdg) >>-* (fn tjdg => 95 | go (Tl.snoc r x (I.replace tjdg jdg)) (ts, out psi)) 96 | | ([], CONS (x, jdg, psi)) => 97 | go (Tl.snoc r x (I.map (ret isjdg) jdg)) ([], out psi) 98 | in 99 | M.shortcircuit (go Tl.empty (ts, out psi), Tl.isEmpty, fn psi => M.ret (psi |> vl)) 100 | end 101 | 102 | 103 | fun eachSeq (ts : jdg tactic list) (psi |> vl) = 104 | let 105 | open Tl.ConsView 106 | fun go rho (r : jdg state I.t telescope) = 107 | fn (_, EMPTY) => M.ret r 108 | | (t :: ts, CONS (x, jdg, psi)) => 109 | wrap t (J.subst rho (I.run jdg)) >>-* 110 | (fn tjdg as (psix |> vlx) => 111 | let 112 | val rho' = L.Ctx.insert rho x vlx 113 | in 114 | go rho' (Tl.snoc r x (I.replace tjdg jdg)) (ts, out psi) 115 | end) 116 | | ([], CONS (x, jdg, psi)) => 117 | go rho (Tl.snoc r x (I.map (ret isjdg) jdg)) ([], out psi) 118 | in 119 | M.shortcircuit (go L.Ctx.empty Tl.empty (ts, out psi), Tl.isEmpty, fn psi => M.ret (psi |> vl)) 120 | end 121 | 122 | fun tabulate (f : int -> jdg tactic) (psi |> vl) = 123 | let 124 | val len = Tl.foldl (fn (_, _, n) => n + 1) 0 psi 125 | in 126 | eachSeq (List.tabulate (len, f)) (psi |> vl) 127 | end 128 | 129 | fun eachSeqWithDefault (ts, tdef) = 130 | tabulate (fn i => List.nth (ts, i) handle _ => tdef) 131 | 132 | fun only (i, t) = 133 | let 134 | val ts = List.tabulate (i + 1, fn j => if i = j then t else idn) 135 | in 136 | each ts 137 | end 138 | 139 | fun allSeq t (psi |> vl) = 140 | eachSeq (Tl.foldr (fn (_,_,ts) => t :: ts) [] psi) (psi |> vl) 141 | 142 | fun all t (psi |> vl) = 143 | each (Tl.foldr (fn (_,_,ts) => t :: ts) [] psi) (psi |> vl) 144 | 145 | fun seq (t: jdg tactic, m : jdg multitactic) jdg = 146 | wrap t jdg >>-* M.map (mul isjdg) o m 147 | 148 | exception Progress 149 | exception Complete 150 | 151 | fun then_ (t1, t2) = 152 | seq (t1, allSeq t2) 153 | 154 | fun thenl (t, ts) = 155 | seq (t, eachSeq ts) 156 | 157 | fun thenf (t, (i, t')) = 158 | seq (t, only (i, t')) 159 | 160 | fun orelse_ (t1, t2) jdg = 161 | M.or (wrap t1 jdg, wrap t2 jdg) 162 | 163 | fun par (t1, t2) jdg = 164 | M.par(wrap t1 jdg, wrap t2 jdg) 165 | 166 | fun morelse (mt1, mt2) st = 167 | M.or (wrap mt1 st, wrap mt2 st) 168 | 169 | fun mpar (mt1, mt2) st = 170 | M.par (wrap mt1 st, wrap mt2 st) 171 | 172 | fun try t = 173 | orelse_ (t, idn) 174 | 175 | local 176 | open Tl.ConsView 177 | fun unifySubtelescopeAux (env1, env2) (psi1, psi2) = 178 | case (out psi1, out psi2) of 179 | (EMPTY, _) => SOME (env1, env2) 180 | | (CONS (x1, jdg1, psi1'), CONS (x2, jdg2, psi2')) => 181 | if J.eq (J.ren env1 (I.run jdg1), J.ren env2 (I.run jdg2)) then 182 | let 183 | val y = L.fresh () 184 | val env1y = L.Ctx.insert env1 x1 y 185 | val env2y = L.Ctx.insert env2 x2 y 186 | in 187 | unifySubtelescopeAux (env1y, env2y) (psi1', psi2') 188 | end 189 | else 190 | unifySubtelescopeAux (env1, env2) (psi1, psi2') 191 | | _ => NONE 192 | in 193 | val unifySubtelescope = unifySubtelescopeAux (L.Ctx.empty, L.Ctx.empty) 194 | end 195 | 196 | val isSubtelescope = 197 | Option.isSome o unifySubtelescope 198 | 199 | exception Progress 200 | exception Complete 201 | 202 | fun progress t (jdg : jdg) = 203 | t jdg >>-* (fn st as (psi |> vl) => 204 | let 205 | open Tl.ConsView 206 | val psi' = Tl.singleton (L.fresh ()) (I.ret jdg) 207 | in 208 | case out psi of 209 | CONS (_, jdg', rest) => 210 | if J.eq (jdg, I.run jdg') then 211 | M.throw Progress 212 | else 213 | M.ret st 214 | | _ => M.ret st 215 | end) 216 | 217 | fun mprogress mt (st as (psi |> _)) = 218 | mt st >>-* (fn sst => 219 | let 220 | val psi' |> _ = mul isjdg sst 221 | in 222 | case unifySubtelescope (psi, psi') of 223 | SOME _ => M.throw Progress 224 | | NONE => M.ret sst 225 | end) 226 | 227 | fun complete t jdg = 228 | wrap t jdg >>-* (fn st as (psi |> _) => 229 | if Tl.isEmpty psi then 230 | M.ret st 231 | else 232 | M.throw Complete) 233 | end -------------------------------------------------------------------------------- /src/dependent_lcf/tactic.sig: -------------------------------------------------------------------------------- 1 | signature LCF_TACTIC_MONAD = 2 | sig 3 | type 'a m 4 | 5 | val run : 'a m * ('a -> bool) -> 'a 6 | 7 | val throw : exn -> 'a m 8 | val par : 'a m * 'a m -> 'a m 9 | val or : 'a m * 'a m -> 'a m 10 | 11 | val map : ('a -> 'b) -> 'a m -> 'b m 12 | val mapErr : (exn -> exn) -> 'a m -> 'a m 13 | val ret : 'a -> 'a m 14 | val mul : 'a m m -> 'a m 15 | 16 | val shortcircuit : 'a m * ('a -> bool) * ('a -> 'b m) -> 'b m 17 | end 18 | 19 | signature LCF_TACTIC = 20 | sig 21 | include LCF 22 | 23 | structure J : LCF_JUDGMENT where type sort = L.sort and type env = L.term L.Ctx.dict 24 | 25 | type jdg = J.jdg 26 | val isjdg : jdg isjdg 27 | 28 | structure M : LCF_TACTIC_MONAD 29 | 30 | type 'a rule = 'a -> 'a state 31 | type 'a tactic = 'a -> 'a state M.m 32 | type 'a multitactic = 'a state tactic 33 | 34 | val rule : 'a rule -> 'a tactic 35 | 36 | val all : jdg tactic -> jdg multitactic 37 | val each : jdg tactic list -> jdg multitactic 38 | val only : int * jdg tactic -> jdg multitactic 39 | 40 | val allSeq : jdg tactic -> jdg multitactic 41 | val eachSeq : jdg tactic list -> jdg multitactic 42 | val tabulate : (int -> jdg tactic) -> jdg multitactic 43 | val eachSeqWithDefault : jdg tactic list * jdg tactic -> jdg multitactic 44 | 45 | val seq : jdg tactic * jdg multitactic -> jdg tactic 46 | val then_ : jdg tactic * jdg tactic -> jdg tactic 47 | val thenl : jdg tactic * jdg tactic list -> jdg tactic 48 | val thenf : jdg tactic * (int * jdg tactic) -> jdg tactic 49 | 50 | val idn : jdg tactic 51 | val orelse_ : jdg tactic * jdg tactic -> jdg tactic 52 | val par : jdg tactic * jdg tactic -> jdg tactic 53 | val mpar : jdg tactic * jdg tactic -> jdg tactic 54 | val try : jdg tactic -> jdg tactic 55 | 56 | val morelse : jdg multitactic * jdg multitactic -> jdg multitactic 57 | 58 | exception Progress 59 | val progress : jdg tactic -> jdg tactic 60 | val mprogress : jdg multitactic -> jdg multitactic 61 | 62 | exception Complete 63 | val complete : jdg tactic -> jdg tactic 64 | end --------------------------------------------------------------------------------