├── .gitignore ├── .gitmodules ├── development.cm ├── logical-framework.cm ├── logical-framework.mlb ├── sml.json ├── src ├── lf │ ├── exn.fun │ ├── exn.sig │ ├── list_util.sig │ ├── list_util.sml │ ├── print.fun │ ├── print.sig │ ├── symbol.fun │ ├── symbol.sig │ ├── syntax.fun │ ├── syntax.sig │ ├── typing.fun │ └── typing.sig └── refiner │ ├── refiner.fun │ └── refiner.sig ├── test └── example.sml └── twelf ├── lf.elf └── sources.cfg /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .cm 5 | *.out 6 | *.x86-darwin 7 | abt 8 | abt-lcs 9 | *.grm.desc 10 | *.grm.sig 11 | *.grm.sml 12 | *.lex.sml 13 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "lib/cmlib"] 2 | path = lib/cmlib 3 | url = https://github.com/standardml/cmlib.git 4 | -------------------------------------------------------------------------------- /development.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | lib/cmlib/cmlib.cm 3 | src/lf/symbol.sig 4 | src/lf/list_util.sig 5 | src/lf/syntax.sig 6 | src/lf/exn.sig 7 | src/lf/typing.sig 8 | src/lf/print.sig 9 | 10 | src/lf/list_util.sml 11 | src/lf/exn.fun 12 | src/lf/symbol.fun 13 | src/lf/syntax.fun 14 | src/lf/print.fun 15 | src/lf/typing.fun 16 | 17 | src/refiner/refiner.sig 18 | src/refiner/refiner.fun 19 | 20 | test/example.sml 21 | -------------------------------------------------------------------------------- /logical-framework.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature LF_SYMBOL 3 | signature LF_SYMBOL_WITH_CONSTANTS 4 | signature LF_SYMBOL_CONSTANT 5 | signature LF_EXN 6 | signature LF_SYNTAX 7 | signature LF_SYNTAX_PRINT 8 | signature LF_TYPING 9 | functor LfSymbol 10 | functor LfSymbolWithConstants 11 | functor LfSyntax 12 | functor LfSyntaxPrint 13 | functor LfTyping 14 | is 15 | lib/cmlib/cmlib.cm 16 | src/lf/symbol.sig 17 | src/lf/list_util.sig 18 | src/lf/syntax.sig 19 | src/lf/print.sig 20 | src/lf/exn.sig 21 | src/lf/typing.sig 22 | 23 | src/lf/list_util.sml 24 | src/lf/exn.fun 25 | src/lf/symbol.fun 26 | src/lf/syntax.fun 27 | src/lf/print.fun 28 | src/lf/typing.fun 29 | -------------------------------------------------------------------------------- /logical-framework.mlb: -------------------------------------------------------------------------------- 1 | local 2 | lib/cmlib/cmlib.mlb 3 | src/lf/symbol.sig 4 | src/lf/list_util.sig 5 | src/lf/syntax.sig 6 | src/lf/exn.sig 7 | src/lf/typing.sig 8 | src/lf/print.sig 9 | 10 | src/lf/list_util.sml 11 | src/lf/exn.fun 12 | src/lf/symbol.fun 13 | src/lf/syntax.fun 14 | src/lf/print.fun 15 | src/lf/typing.fun 16 | in 17 | signature LF_SYMBOL 18 | signature LF_SYMBOL_WITH_CONSTANTS 19 | signature LF_SYMBOL_CONSTANT 20 | signature LF_EXN 21 | signature LF_SYNTAX 22 | signature LF_TYPING 23 | signature LF_SYNTAX_PRINT 24 | functor LfSymbol 25 | functor LfSymbolWithConstants 26 | functor LfSyntax 27 | functor LfSyntaxPrint 28 | functor LfTyping 29 | end 30 | -------------------------------------------------------------------------------- /sml.json: -------------------------------------------------------------------------------- 1 | { 2 | "cm": { 3 | "make/onSave": "development.cm" 4 | } 5 | } -------------------------------------------------------------------------------- /src/lf/exn.fun: -------------------------------------------------------------------------------- 1 | functor LfExnUtil (Exn : LF_EXN) : LF_EXN_UTIL = 2 | struct 3 | open Exn 4 | fun debug e = 5 | e () 6 | handle LfExn err => 7 | (print ("\n" ^ description err ^ "\n"); 8 | raise LfExn err) 9 | | exn => 10 | (print ("\n" ^ exnMessage exn ^ "\n"); 11 | raise exn) 12 | end -------------------------------------------------------------------------------- /src/lf/exn.sig: -------------------------------------------------------------------------------- 1 | signature LF_EXN = 2 | sig 3 | type error 4 | exception LfExn of error 5 | val description : error -> string 6 | end 7 | 8 | signature LF_EXN_UTIL = 9 | sig 10 | include LF_EXN 11 | val debug : (unit -> 'a) -> 'a 12 | end -------------------------------------------------------------------------------- /src/lf/list_util.sig: -------------------------------------------------------------------------------- 1 | signature LIST_UTIL = 2 | sig 3 | val unsnoc : 'a list -> ('a list * 'a) option 4 | end 5 | -------------------------------------------------------------------------------- /src/lf/list_util.sml: -------------------------------------------------------------------------------- 1 | structure ListUtil : LIST_UTIL = 2 | struct 3 | fun unsnoc xs = 4 | let 5 | val n = List.length xs - 1 6 | val x = List.nth (xs, n) 7 | val xs' = List.take (xs, n) 8 | in 9 | SOME (xs', x) 10 | end 11 | handle General.Subscript => NONE 12 | end 13 | -------------------------------------------------------------------------------- /src/lf/print.fun: -------------------------------------------------------------------------------- 1 | functor LfSyntaxPrint (Lf : LF_SYNTAX) : LF_SYNTAX_PRINT = 2 | struct 3 | open Lf 4 | infix 0 @@ 5 | infix 1 \ \\ `@ --> ==> 6 | 7 | fun var x = 8 | Sym.toString x 9 | 10 | fun vars xs = 11 | case xs of 12 | [] => "" 13 | | x :: [] => var x 14 | | x :: xs => var x ^ "," ^ vars xs 15 | 16 | fun pi (Psi \ rcl) = 17 | case Psi of 18 | [] => rclass rcl 19 | | _ => "{" ^ ctx Psi ^ "}" ^ rclass rcl 20 | 21 | and class cl = 22 | pi (Unbind.class cl) 23 | 24 | and ctx Psi = 25 | case Psi of 26 | [] => "-" 27 | | (x, cl) :: [] => var x ^ ":" ^ class cl 28 | | (x, cl) :: Psi' => var x ^ ":" ^ class cl ^ ", " ^ ctx Psi' 29 | 30 | and rclass rcl = 31 | case rcl of 32 | `r => rtm r 33 | | TYPE => "*" 34 | 35 | and rtm (x `@ sp) = 36 | case sp of 37 | [] => var x 38 | | _ => var x ^ "[" ^ spine sp ^ "]" 39 | 40 | and spine sp = 41 | case sp of 42 | [] => "-" 43 | | n :: [] => ntm n 44 | | n :: sp => ntm n ^ "," ^ spine sp 45 | 46 | and lam (xs \ r) = 47 | case xs of 48 | [] => rtm r 49 | | _ => "[" ^ vars xs ^ "]" ^ rtm r 50 | 51 | and ntm n = 52 | lam (Unbind.ntm n) 53 | end -------------------------------------------------------------------------------- /src/lf/print.sig: -------------------------------------------------------------------------------- 1 | signature LF_SYNTAX_PRINT = 2 | sig 3 | include LF_SYNTAX 4 | 5 | val var : var -> string 6 | val rclass : rclass -> string 7 | val class : class -> string 8 | val rtm : rtm -> string 9 | val ntm : ntm -> string 10 | val spine : spine -> string 11 | val ctx : ctx -> string 12 | end 13 | -------------------------------------------------------------------------------- /src/lf/symbol.fun: -------------------------------------------------------------------------------- 1 | functor LfSymbol () :> LF_SYMBOL = 2 | struct 3 | type symbol = string * int 4 | 5 | val counter = ref 0 6 | 7 | fun named a = 8 | let 9 | val i = !counter 10 | in 11 | counter := i + 1; 12 | (a, i) 13 | end 14 | 15 | fun new () = 16 | named "" 17 | 18 | fun name (a, i) = 19 | case a of 20 | "" => "?" ^ Int.toString i 21 | | _ => a 22 | 23 | val toString = name 24 | 25 | structure Key = 26 | struct 27 | type t = symbol 28 | fun eq ((_,i : int), (_, j)) = i = j 29 | fun compare ((_,i), (_,j)) = Int.compare (i, j) 30 | end 31 | 32 | open Key 33 | structure Env = SplayDict (structure Key = Key) 34 | end 35 | 36 | signature LF_SYMBOL_CONSTANT = 37 | sig 38 | type constant 39 | val eq : constant * constant -> bool 40 | val compare : constant * constant -> order 41 | val toString : constant -> string 42 | end 43 | 44 | functor LfSymbolWithConstants(C : LF_SYMBOL_CONSTANT) : LF_SYMBOL_WITH_CONSTANTS where type constant = C.constant = 45 | struct 46 | structure Sym = LfSymbol () 47 | type constant = C.constant 48 | type identifier = Sym.symbol 49 | 50 | datatype ext_symbol = 51 | C of constant 52 | | I of identifier 53 | 54 | type symbol = ext_symbol 55 | 56 | val new = I o Sym.new 57 | 58 | val named = I o Sym.named 59 | 60 | val toString = 61 | fn C c => C.toString c 62 | | I i => Sym.toString i 63 | 64 | val name = 65 | fn C c => C.toString c 66 | | I i => Sym.name i 67 | 68 | structure Key = 69 | struct 70 | type t = symbol 71 | val eq = 72 | fn (C c1, C c2) => C.eq (c1, c2) 73 | | (I i1, I i2) => Sym.eq (i1, i2) 74 | | _ => false 75 | 76 | val compare = 77 | fn (C c1, C c2) => C.compare (c1, c2) 78 | | (I i1, I i2) => Sym.compare (i1, i2) 79 | | (C _, I _) => GREATER 80 | | _ => LESS 81 | end 82 | 83 | open Key 84 | structure Env = SplayDict (structure Key = Key) 85 | end -------------------------------------------------------------------------------- /src/lf/symbol.sig: -------------------------------------------------------------------------------- 1 | signature LF_SYMBOL = 2 | sig 3 | type symbol 4 | val eq : symbol * symbol -> bool 5 | val compare : symbol * symbol -> order 6 | 7 | val new : unit -> symbol 8 | val named : string -> symbol 9 | val toString : symbol -> string 10 | val name : symbol -> string 11 | 12 | structure Env : DICT where type key = symbol 13 | end 14 | 15 | signature LF_SYMBOL_WITH_CONSTANTS = 16 | sig 17 | type identifier 18 | type constant 19 | 20 | datatype ext_symbol = 21 | C of constant 22 | | I of identifier 23 | 24 | include LF_SYMBOL where type symbol = ext_symbol 25 | end -------------------------------------------------------------------------------- /src/lf/syntax.fun: -------------------------------------------------------------------------------- 1 | functor LfSyntax (Sym : LF_SYMBOL) :> LF_SYNTAX where type Sym.symbol = Sym.symbol where type 'a Sym.Env.dict = 'a Sym.Env.dict = 2 | struct 3 | structure Sym = Sym 4 | structure Env = Sym.Env 5 | 6 | type var = Sym.symbol 7 | type 'a env = 'a Sym.Env.dict 8 | 9 | datatype ('v, 'a) app = `@ of 'v * 'a list 10 | 11 | (* atomic classifiers *) 12 | datatype 'v rclass_ = 13 | ` of 'v rtm_ 14 | | TYPE 15 | and ('a, 'b) bind = \ of 'a list * 'b 16 | and 'v class_ = PI of ('v * 'v class_, 'v rclass_) bind 17 | and 'v ntm_ = LAM of ('v, 'v rtm_) bind 18 | withtype 'v rtm_ = ('v, 'v ntm_) app 19 | 20 | type 'v spine_ = 'v ntm_ list 21 | type 'v ctx_ = ('v * 'v class_) list 22 | 23 | type ntm = var ntm_ 24 | type rtm = var rtm_ 25 | type rclass = var rclass_ 26 | type class = var class_ 27 | type ctx = var ctx_ 28 | type spine = var spine_ 29 | 30 | fun @@ (f, x) = f x 31 | infix 0 @@ 32 | infix 1 \ \\ `@ --> ==> 33 | 34 | fun unifyVars (rho1, rho2) (x1, x2) = 35 | let 36 | val z = Sym.new () 37 | in 38 | (Sym.Env.insert rho1 x1 z, Sym.Env.insert rho2 x2 z) 39 | end 40 | 41 | fun lookupVar rho x = 42 | Sym.Env.lookup rho x 43 | handle _ => x 44 | 45 | structure Ren = 46 | struct 47 | type ren = var env 48 | 49 | fun class rho (PI (Psi \ rcl)) = 50 | let 51 | val (rho', Psi') = ctx rho Psi 52 | val rcl' = rclass rho' rcl 53 | in 54 | PI (Psi' \ rcl') 55 | end 56 | and rclass rho = 57 | fn TYPE => TYPE 58 | | `r => ` (rtm rho r) 59 | and rtm rho (x `@ sp) = 60 | lookupVar rho x `@ spine rho sp 61 | and spine rho = List.map (ntm rho) 62 | and ntm rho (LAM (xs \ r)) = 63 | LAM (xs \ rtm (List.foldl (fn (x, rho) => Sym.Env.remove rho x) rho xs) r) 64 | and ctx rho Psi = 65 | let 66 | fun go rho [] Psi = (rho, Psi) 67 | | go rho ((x, cl) :: Psi) Psi' = go (Sym.Env.remove rho x) Psi ((x, class rho cl) :: Psi') 68 | 69 | val (rho', Psi') = go rho Psi [] 70 | in 71 | (rho', List.rev Psi') 72 | end 73 | 74 | fun rebindCtx xs Psi = 75 | let 76 | fun go rho [] [] out = (rho, out) 77 | | go rho (x :: xs) ((y, cl) :: Psi) out = 78 | go (Sym.Env.insert rho y x) xs Psi ((x, class rho cl) :: out) 79 | | go _ _ _ _ = raise Fail "Incorrect length of contexts" 80 | val (rho', Psi') = go Sym.Env.empty xs Psi [] 81 | in 82 | (rho', List.rev Psi') 83 | end 84 | end 85 | 86 | fun xs \\ r = 87 | LAM (xs \ r) 88 | 89 | fun Psi --> rcl = 90 | PI (Psi \ rcl) 91 | 92 | fun cls ==> cl = 93 | List.map (fn x => (Sym.new (), x)) cls --> cl 94 | 95 | structure Unbind = 96 | struct 97 | fun ntm (LAM (xs \ r)) = 98 | let 99 | val xs' = List.map (Sym.named o Sym.name) xs 100 | val rho = ListPair.foldr (fn (x, x', rho) => Sym.Env.insert rho x x') Sym.Env.empty (xs, xs') 101 | val r' = Ren.rtm rho r 102 | in 103 | xs' \ r' 104 | end 105 | 106 | fun rtm (x `@ ns) = 107 | x `@ List.map ntm ns 108 | 109 | fun class (PI (Psi \ rcl)) = 110 | let 111 | val xs = List.map (Sym.named o Sym.name o #1) Psi 112 | val (rho, Psi') = Ren.rebindCtx xs Psi 113 | val rcl' = Ren.rclass rho rcl 114 | in 115 | Psi' \ rcl' 116 | end 117 | end 118 | 119 | structure Parsing = 120 | struct 121 | val op\\ = op\\ 122 | val op--> = op--> 123 | fun cls ==> cl = 124 | List.map (fn x => ("_", x)) cls --> cl 125 | end 126 | 127 | structure Bind = 128 | struct 129 | type bind_env = var StringListDict.dict 130 | 131 | (* assignment of identity to variables is performed in the state monad, so that we can give a single identity to *free* variables of the same name, 132 | without taking a context as input. *) 133 | type 'a m = bind_env -> 'a * bind_env 134 | 135 | fun ret a env = (a, env) 136 | fun >>= (m : 'a m, f : 'a -> 'b m) : 'b m = 137 | fn env => 138 | let 139 | val (a, env') = m env 140 | in 141 | f a env' 142 | end 143 | 144 | fun >> (m, n) = 145 | >>= (m, fn _ => n) 146 | 147 | infixr >>= >> 148 | 149 | fun local_ (f : bind_env -> bind_env) (m : 'a m) : 'a m = m o f 150 | fun addVars xs env = List.foldr (fn (x, env) => StringListDict.insert env (Sym.name x) x) env xs 151 | fun peek (xs : string list) (m : var list -> 'a m) : 'a m = 152 | let 153 | val xs' = List.map Sym.named xs 154 | in 155 | m xs' o addVars xs' 156 | end 157 | 158 | fun run m = m 159 | 160 | fun var x : var m = 161 | fn env => 162 | case StringListDict.find env x of 163 | SOME x' => (x', env) 164 | | NONE => 165 | let 166 | val x' = Sym.named x 167 | in 168 | (x', StringListDict.insert env x x') 169 | end 170 | 171 | fun rclass rcl : rclass m = 172 | case rcl of 173 | TYPE => ret TYPE 174 | | ` r => rtm r >>= ret o ` 175 | 176 | and class (PI (Psi \ rcl)) : class m = 177 | ctx Psi >>= (fn Psi' => 178 | peek (List.map #1 Psi) (fn xs => 179 | let 180 | val (_, Psi'') = Ren.rebindCtx xs Psi' 181 | in 182 | rclass rcl >>= (fn rcl' => 183 | ret @@ PI (Psi'' \ rcl')) 184 | end)) 185 | 186 | and rtm (x `@ sp) : rtm m = 187 | var x >>= (fn x' => 188 | spine sp >>= (fn sp' => 189 | ret @@ x' `@ sp')) 190 | 191 | and ntm (LAM (xs \ r)) : ntm m = 192 | peek xs (fn xs' => 193 | rtm r >>= (fn r' => ret @@ LAM (xs' \ r'))) 194 | 195 | and spine sp : spine m = 196 | case sp of 197 | [] => ret [] 198 | | n::sp => 199 | ntm n >>= (fn n' => 200 | spine sp >>= (fn sp' => 201 | ret @@ n' :: sp')) 202 | 203 | and ctx Psi : ctx m = 204 | case Psi of 205 | [] => ret [] 206 | | (x,cl) :: Psi => 207 | class cl >>= (fn cl' => 208 | peek [x] (fn [x'] => 209 | ctx Psi >>= (fn Psi' => 210 | ret @@ (x', cl') :: Psi'))) 211 | end 212 | 213 | fun eta (x : var, cl : class) : ntm = 214 | let 215 | val Psi \ rcl = Unbind.class cl 216 | val xs = List.map eta Psi 217 | in 218 | List.map #1 Psi \\ (x `@ xs) 219 | end 220 | 221 | 222 | structure Eq = 223 | struct 224 | type env = var env * var env 225 | val emptyEqEnv = (Sym.Env.empty, Sym.Env.empty) 226 | 227 | val unifyBinders : env -> var list * var list -> env = 228 | ListPair.foldlEq 229 | (fn (x1, x2, (rho1, rho2)) => 230 | unifyVars (rho1, rho2) (x1, x2)) 231 | 232 | fun varAux (rho1, rho2) (x1, x2) = 233 | Sym.eq (lookupVar rho1 x1, lookupVar rho2 x2) 234 | 235 | fun classAux env (PI (Psi1 \ rcl1), PI (Psi2 \ rcl2)) = 236 | case ctxAux env (Psi1, Psi2) of 237 | SOME env' => rclassAux env' (rcl1, rcl2) 238 | | NONE => false 239 | 240 | and ctxAux env = 241 | let 242 | exception CtxNotEq 243 | fun go env ([], []) = env 244 | | go env ((x1, cl1) :: Psi1, (x2, cl2) :: Psi2) = 245 | if classAux env (cl1, cl2) then 246 | go (unifyVars env (x1, x2)) (Psi1, Psi2) 247 | else 248 | raise CtxNotEq 249 | | go _ _ = raise CtxNotEq 250 | in 251 | fn Psis => 252 | SOME (go env Psis) 253 | handle CtxNotEq => NONE 254 | end 255 | 256 | and rclassAux env (rcl1, rcl2) = 257 | case (rcl1, rcl2) of 258 | (` r1, ` r2) => rtmAux env (r1, r2) 259 | | (TYPE, TYPE) => true 260 | | _ => false 261 | 262 | and rtmAux env (x1 `@ sp1, x2 `@ sp2) = 263 | varAux env (x1, x2) 264 | andalso spineAux env (sp1, sp2) 265 | 266 | and spineAux env (sp1, sp2) = 267 | case (sp1, sp2) of 268 | ([],[]) => true 269 | | (n1 :: sp1', n2 :: sp2') => 270 | ntmAux env (n1, n2) 271 | andalso spineAux env (sp1', sp2') 272 | | _ => false 273 | 274 | and ntmAux env (LAM (xs1 \ r1), LAM (xs2 \ r2)) = 275 | rtmAux 276 | (unifyBinders env (xs1, xs2)) 277 | (r1, r2) 278 | 279 | val var = varAux emptyEqEnv 280 | val rclass = rclassAux emptyEqEnv 281 | val class = classAux emptyEqEnv 282 | val ntm = ntmAux emptyEqEnv 283 | val spine = spineAux emptyEqEnv 284 | val rtm = rtmAux emptyEqEnv 285 | val ctx = Option.isSome o ctxAux emptyEqEnv 286 | end 287 | 288 | 289 | structure SubstN = 290 | struct 291 | fun zipSpine (xs, sp) = 292 | ListPair.foldr 293 | (fn (x, n, rho) => Sym.Env.insert rho x n) 294 | Sym.Env.empty 295 | (xs, sp) 296 | 297 | fun class rho (PI (Psi \ rcl)) = 298 | PI (ctx rho Psi \ rclass rho rcl) 299 | and ctx rho Psi = 300 | case Psi of 301 | [] => [] 302 | | (x, cl) :: Psi' => (x, class rho cl) :: ctx (Sym.Env.remove rho x) Psi' 303 | and rclass rho = 304 | fn TYPE => TYPE 305 | | `r => ` (rtm rho r) 306 | and rtm rho (x `@ sp) = 307 | let 308 | val sp' = spine rho sp 309 | in 310 | case Sym.Env.find rho x of 311 | SOME (LAM (xs \ r)) => rtm (zipSpine (xs, sp')) r 312 | | NONE => x `@ sp' 313 | end 314 | and ntm rho (LAM (xs \ r)) = 315 | LAM (xs \ rtm (List.foldl (fn (x, rho') => Sym.Env.remove rho' x) rho xs) r) 316 | and spine rho = List.map (ntm rho) 317 | end 318 | 319 | structure SubstRcl = 320 | struct 321 | type subst = (var, rclass) bind env 322 | 323 | fun class rho (PI (Psi \ rcl)) = 324 | PI (ctx rho Psi \ rclass rho rcl) 325 | and ctx rho Psi = 326 | case Psi of 327 | [] => [] 328 | | (x, cl) :: Psi' => (x, class rho cl) :: ctx (Sym.Env.remove rho x) Psi' 329 | and rclass rho = 330 | fn TYPE => TYPE 331 | | `(x `@ sp) => 332 | let 333 | val sp' = spine rho sp 334 | in 335 | case Sym.Env.find rho x of 336 | SOME (xs \ rcl) => SubstN.rclass (SubstN.zipSpine (xs, sp')) rcl 337 | | NONE => `(x `@ sp') 338 | end 339 | and rtm rho (x `@ sp) = 340 | let 341 | val sp' = spine rho sp 342 | in 343 | (* Is this correct? *) 344 | (x `@ sp') 345 | end 346 | and ntm rho (LAM (xs \ r)) = 347 | LAM (xs \ rtm (List.foldl (fn (x, rho') => Sym.Env.remove rho' x) rho xs) r) 348 | and spine rho = List.map (ntm rho) 349 | end 350 | 351 | structure Ctx = 352 | struct 353 | fun splitAux Gamma0 Gamma1 x = 354 | case Gamma1 of 355 | [] => raise Fail "Variable not found" 356 | | (y, a) :: Gamma1 => if Sym.eq (x, y) then (Gamma0, a, Gamma1) else splitAux Gamma0 Gamma1 x 357 | 358 | fun split Gamma x = 359 | let 360 | val (Gamma0, a, Gamma1) = splitAux [] Gamma x 361 | in 362 | (List.rev Gamma0, a, Gamma1) 363 | end 364 | end 365 | end 366 | -------------------------------------------------------------------------------- /src/lf/syntax.sig: -------------------------------------------------------------------------------- 1 | signature LF_SYNTAX = 2 | sig 3 | structure Sym : LF_SYMBOL 4 | type var = Sym.symbol 5 | type 'a env = 'a Sym.Env.dict 6 | 7 | type 'v ntm_ (* normal terms *) 8 | type 'v spine_ = 'v ntm_ list 9 | type 'v class_ (* general classifiers *) 10 | type 'v ctx_ = ('v * 'v class_) list 11 | 12 | datatype ('v, 'a) app = `@ of 'v * 'a list 13 | datatype ('v, 'a) bind = \ of 'v list * 'a 14 | 15 | type 'v rtm_ = ('v, 'v ntm_) app (* atomic terms *) 16 | datatype 'v rclass_ = ` of 'v rtm_ | TYPE (* atomic classifiers *) 17 | 18 | type ntm = var ntm_ 19 | type rtm = var rtm_ 20 | type rclass = var rclass_ 21 | type class = var class_ 22 | type ctx = var ctx_ 23 | type spine = var spine_ 24 | 25 | val \\ : var list * rtm -> ntm 26 | val --> : ctx * rclass -> class 27 | val ==> : class list * rclass -> class 28 | 29 | val eta : var * class -> ntm 30 | 31 | structure Unbind : 32 | sig 33 | val ntm : ntm -> (var, rtm) bind 34 | val rtm : rtm -> (var, (var, rtm) bind) app 35 | val class : class -> (var * class, rclass) bind 36 | end 37 | 38 | structure Parsing : 39 | sig 40 | val \\ : string list * string rtm_ -> string ntm_ 41 | val --> : string ctx_ * string rclass_ -> string class_ 42 | val ==> : string class_ list * string rclass_ -> string class_ 43 | end 44 | 45 | (* For assigning identity to variables in concrete syntax *) 46 | structure Bind : 47 | sig 48 | type bind_env = var StringListDict.dict 49 | type 'a m 50 | 51 | val run : 'a m -> bind_env -> 'a * bind_env 52 | 53 | val var : string -> var m 54 | val rclass : string rclass_ -> rclass m 55 | val class : string class_ -> class m 56 | val ntm : string ntm_ -> ntm m 57 | val rtm : string rtm_ -> rtm m 58 | val spine : string spine_ -> spine m 59 | val ctx : string ctx_ -> ctx m 60 | end 61 | 62 | (* alpha equivalence *) 63 | structure Eq : 64 | sig 65 | val var : var * var -> bool 66 | val rclass : rclass * rclass -> bool 67 | val class : class * class -> bool 68 | val rtm : rtm * rtm -> bool 69 | val ntm : ntm * ntm -> bool 70 | val spine : spine * spine -> bool 71 | val ctx : ctx * ctx -> bool 72 | end 73 | 74 | (* capture-avoiding renaming *) 75 | structure Ren : 76 | sig 77 | type ren = var env 78 | val rclass : ren -> rclass -> rclass 79 | val class : ren -> class -> class 80 | val rtm : ren -> rtm -> rtm 81 | val ntm : ren -> ntm -> ntm 82 | val spine : ren -> spine -> spine 83 | val ctx : ren -> ctx -> ren * ctx 84 | 85 | val rebindCtx : var list -> ctx -> ren * ctx 86 | end 87 | 88 | (* capture-avoiding substitution *) 89 | structure SubstN : 90 | sig 91 | val rclass : ntm env -> rclass -> rclass 92 | val class : ntm env -> class -> class 93 | val rtm : ntm env -> rtm -> rtm 94 | val ntm : ntm env -> ntm -> ntm 95 | val spine : ntm env -> spine -> spine 96 | val ctx : ntm env -> ctx -> ctx 97 | 98 | val zipSpine : var list * spine -> ntm env 99 | end 100 | 101 | structure SubstRcl : 102 | sig 103 | type subst = (var, rclass) bind env 104 | val rclass : subst -> rclass -> rclass 105 | val class : subst -> class -> class 106 | val rtm : subst -> rtm -> rtm 107 | val ntm : subst -> ntm -> ntm 108 | val spine : subst -> spine -> spine 109 | val ctx : subst -> ctx -> ctx 110 | end 111 | 112 | structure Ctx : 113 | sig 114 | val split : ctx -> var -> ctx * class * ctx 115 | end 116 | end 117 | -------------------------------------------------------------------------------- /src/lf/typing.fun: -------------------------------------------------------------------------------- 1 | functor LfTyping (Syn : LF_SYNTAX) : LF_TYPING = 2 | struct 3 | open Syn 4 | structure Print = LfSyntaxPrint (Syn) 5 | 6 | fun @@ (f, x) = f x 7 | infix `@ \ \\ @@ 8 | 9 | datatype error = 10 | EXPECTED_TYPE of {expected : rclass, actual : rclass} 11 | | MISSING_VARIABLE of {var : var, ctx : ctx} 12 | | SPINE_MISMATCH of {spine : spine, ctx : ctx} 13 | 14 | (* The typechecker is organized as a machine using a variation on the Dependent LCF 15 | architecture, as described in Sterling/Harper 2017, but applied to a deterministic 16 | and syntax-directed logic. In this special case, there is only one primitive rule, 17 | which can be thought of as a *local* version of the transition function for a 18 | type-checking machine. *) 19 | 20 | datatype judgment = 21 | OK_CLASS of ctx * class 22 | | CHK of ctx * ntm * class 23 | | INF of ctx * rtm 24 | | CHK_SP of ctx * spine * ctx 25 | | CTX of ctx * ctx 26 | | EQ of rclass * rclass 27 | 28 | (* Our machine has three instructions: we can push a judgment onto the stack, 29 | we can throw an error (aborting the process), or we can return. *) 30 | datatype 'a instr = 31 | PUSH of judgment 32 | | THROW of error 33 | | RET of rclass 34 | 35 | type metavar = var 36 | type history = judgment list 37 | type goal = metavar * history * judgment instr 38 | type stack = goal list 39 | 40 | fun push jdg = (Sym.new (), PUSH jdg) 41 | fun throw err = (Sym.new (), THROW err) 42 | 43 | type synthesis = rclass option 44 | datatype 'a refine = |> of (metavar * 'a instr) list * synthesis 45 | infix |> 46 | 47 | val printError : error -> string = 48 | fn EXPECTED_TYPE {expected, actual} => 49 | "Got type [" ^ Print.rclass actual ^ "] but it should have been [" ^ Print.rclass expected ^ "]." 50 | | MISSING_VARIABLE {var, ctx} => 51 | "Could not find variable [" ^ Print.var var ^ "] in context [" ^ Print.ctx ctx ^ "]." 52 | | SPINE_MISMATCH {spine, ctx} => 53 | "The spine [" ^ Print.spine spine ^ "] could not be checked against a context of incorrect length, [" ^ Print.ctx ctx ^ "]." 54 | 55 | val printJudgment = 56 | fn OK_CLASS (Gamma, cl) => Print.ctx Gamma ^ " !- " ^ Print.class cl ^ " ok" 57 | | CHK (Gamma, n, cl) => Print.ctx Gamma ^ " !- " ^ Print.ntm n ^ " <= " ^ Print.class cl 58 | | INF (Gamma, r) => Print.ctx Gamma ^ " !- " ^ Print.rtm r ^ " => _" 59 | | CHK_SP (Gamma, sp, Psi) => Print.ctx Gamma ^ " !- [" ^ Print.spine sp ^ "] <= [" ^ Print.ctx Psi ^ "]" 60 | | CTX (Gamma, Psi) => Print.ctx Gamma ^ " !- " ^ Print.ctx Psi ^ " ctx" 61 | | EQ (rcl1, rcl2) => Print.rclass rcl1 ^ " == " ^ Print.rclass rcl2 62 | 63 | val rec printHistory = 64 | fn [] => "(no history)" 65 | | [jdg] => " - " ^ printJudgment jdg 66 | | jdg :: history => " - " ^ printJudgment jdg ^ "\n" ^ printHistory history 67 | 68 | fun substJudgment (rho : SubstRcl.subst) : judgment -> judgment = 69 | fn OK_CLASS (Gamma, cl) => OK_CLASS (SubstRcl.ctx rho Gamma, SubstRcl.class rho cl) 70 | | CHK (Gamma, n, cl) => CHK (SubstRcl.ctx rho Gamma, SubstRcl.ntm rho n, SubstRcl.class rho cl) 71 | | INF (Gamma, r) => INF (SubstRcl.ctx rho Gamma, SubstRcl.rtm rho r) 72 | | CHK_SP (Gamma, sp, Psi) => CHK_SP (SubstRcl.ctx rho Gamma, SubstRcl.spine rho sp, SubstRcl.ctx rho Psi) 73 | | CTX (Gamma, Psi) => CTX (SubstRcl.ctx rho Gamma, SubstRcl.ctx rho Psi) 74 | | EQ (rcl1, rcl2) => EQ (SubstRcl.rclass rho rcl1, SubstRcl.rclass rho rcl2) 75 | 76 | fun substInstr (rho : SubstRcl.subst) : judgment instr -> judgment instr = 77 | fn PUSH jdg => PUSH (substJudgment rho jdg) 78 | | THROW err => THROW err 79 | | RET rcl => RET (SubstRcl.rclass rho rcl) 80 | 81 | 82 | fun findVar Gamma x = 83 | let 84 | fun go [] = NONE 85 | | go ((y, cl) :: Gamma') = if Eq.var (x, y) then SOME cl else go Gamma' 86 | in 87 | go (List.rev Gamma) 88 | end 89 | 90 | (* The single primitive refinement rule for the Logical Framework. *) 91 | val refine : judgment -> judgment refine = 92 | fn OK_CLASS (Gamma, cl) => 93 | let 94 | val Psi \ rcl = Unbind.class cl 95 | val ctxGoal = push @@ CTX (Gamma, Psi) 96 | in 97 | case rcl of 98 | `r => 99 | let 100 | val infGoal = push @@ INF (Gamma @ Psi, r) 101 | val eqGoal = push @@ EQ (` (#1 infGoal `@ []), TYPE) 102 | in 103 | [ctxGoal,infGoal,eqGoal] |> NONE 104 | end 105 | | TYPE => [ctxGoal] |> NONE 106 | end 107 | | CHK (Gamma, n, cl) => 108 | let 109 | val Psi \ rcl = Unbind.class cl 110 | val xs \ r = Unbind.ntm n 111 | val (rho, Psi') = Ren.rebindCtx xs Psi 112 | val rcl' = Ren.rclass rho rcl 113 | val infGoal = push @@ INF (Gamma @ Psi', r) 114 | val eqGoal = push @@ EQ (rcl', `(#1 infGoal `@ [])) 115 | in 116 | [infGoal, eqGoal] |> NONE 117 | end 118 | | CHK_SP (Gamma, sp, Psi) => 119 | let 120 | val stk = 121 | #1 @@ 122 | ListPair.foldrEq 123 | (fn (n, (x,cl), (stk,rho)) => 124 | let 125 | val cl' = SubstN.class rho cl 126 | val rho' = Sym.Env.insert rho x n 127 | val chkGoal = push @@ CHK (Gamma, n, cl') 128 | in 129 | (chkGoal :: stk, rho') 130 | end) 131 | ([], Sym.Env.empty) 132 | (sp, Psi) 133 | handle ListPair.UnequalLengths => 134 | [throw (SPINE_MISMATCH {ctx = Psi, spine = sp})] 135 | in 136 | stk |> NONE 137 | end 138 | | INF (Gamma, x `@ sp) => 139 | (case findVar Gamma x of 140 | SOME cl => 141 | let 142 | val Psi \ rcl = Unbind.class cl 143 | val rcl' = SubstN.rclass (SubstN.zipSpine (List.map #1 Psi, sp)) rcl 144 | val chkGoal = push @@ CHK_SP (Gamma, sp, Psi) 145 | in 146 | [chkGoal] |> SOME rcl' 147 | end 148 | | NONE => [throw (MISSING_VARIABLE {var = x, ctx = Gamma})] |> NONE) 149 | | CTX (Gamma, Psi) => 150 | (case ListUtil.unsnoc Psi of 151 | NONE => [] |> NONE 152 | | SOME (Psi', (x, cl)) => 153 | let 154 | val ctxGoal = push @@ CTX (Gamma, Psi') 155 | val clGoal = push @@ OK_CLASS (Gamma @ Psi', cl) 156 | in 157 | [ctxGoal, clGoal] |> NONE 158 | end) 159 | | EQ (rcl1, rcl2) => 160 | if Eq.rclass (rcl1, rcl2) then 161 | [] |> NONE 162 | else 163 | [throw (EXPECTED_TYPE {expected = rcl2, actual = rcl1})] |> NONE 164 | 165 | (* Next, we define the transition function for the machine; this can be thought of as a 166 | strategy for deriving judgments in LF using the refinement rule that we have written 167 | above. This hand-written strategy corresponds to "[refine, id...]" in Dependent LCF, 168 | the tactic that runs a rule on the *first subgoal*. *) 169 | local 170 | fun propagate (x : metavar) (synth : synthesis) (stk : stack) = 171 | case synth of 172 | SOME rcl => 173 | let 174 | val rho = Sym.Env.insert Sym.Env.empty x ([] \ rcl) 175 | in 176 | List.map (fn (y, hist, instr) => (y, hist, substInstr rho instr)) stk 177 | end 178 | | NONE => stk 179 | in 180 | val step : stack -> stack option = 181 | fn (x, hist, PUSH jdg) :: stk => 182 | let 183 | val subgoals |> synthesis = refine jdg 184 | val subgoals' = List.map (fn (y, instr) => (y, jdg :: hist, instr)) subgoals 185 | in 186 | SOME (subgoals' @ propagate x synthesis stk) 187 | end 188 | | (_, _, THROW _) :: _ => NONE 189 | | (_, _, RET _) :: _ => NONE 190 | | [] => NONE 191 | end 192 | 193 | (* Finally, we define a routine to run our machine into quiescence. *) 194 | fun eval stk = 195 | case step stk of 196 | NONE => stk 197 | | SOME stk' => eval stk' 198 | 199 | 200 | structure LfExn = 201 | struct 202 | type error = error * history 203 | exception LfExn of error 204 | 205 | val description = 206 | fn (error, []) => printError error 207 | | (error, history) => printError error ^ "\n\nHistory:\n" ^ printHistory history ^ "\n\n" 208 | end 209 | 210 | fun init jdg = [(Sym.new (), [], PUSH jdg)] 211 | val run = eval o init 212 | 213 | structure Chk = 214 | struct 215 | fun class Gamma cl = 216 | case run @@ OK_CLASS (Gamma, cl) of 217 | (_, hist, THROW err) :: _ => raise LfExn.LfExn (err, hist) 218 | | _ => () 219 | 220 | fun ctx Gamma Psi = 221 | case run @@ CTX (Gamma, Psi) of 222 | (_, hist, THROW err) :: _ => raise LfExn.LfExn (err, hist) 223 | | _ => () 224 | 225 | fun ntm Gamma n cl = 226 | case run @@ CHK (Gamma, n, cl) of 227 | (_, hist, THROW err) :: _ => raise LfExn.LfExn (err, hist) 228 | | _ => () 229 | 230 | fun spine Gamma sp Psi = 231 | case run @@ CHK_SP (Gamma, sp, Psi) of 232 | (_, hist, THROW err) :: _ => raise LfExn.LfExn (err, hist) 233 | | _ => () 234 | end 235 | 236 | structure Inf = 237 | struct 238 | fun rtm Gamma r = 239 | let 240 | val infGoal = (Sym.new (), [], PUSH (INF (Gamma, r))) 241 | val retGoal = (Sym.new (), [], RET (` (#1 infGoal `@ []))) 242 | in 243 | case eval [infGoal, retGoal] of 244 | (_, hist, THROW err) :: _ => raise LfExn.LfExn (err, hist) 245 | | (_, _, RET rcl) :: _ => rcl 246 | | _ => raise Fail "Internal error" 247 | end 248 | 249 | fun var Gamma x = 250 | case findVar Gamma x of 251 | SOME cl => cl 252 | | NONE => raise LfExn.LfExn (MISSING_VARIABLE {var = x, ctx = Gamma}, []) 253 | end 254 | 255 | structure LfExn = LfExnUtil (LfExn) 256 | end -------------------------------------------------------------------------------- /src/lf/typing.sig: -------------------------------------------------------------------------------- 1 | signature LF_TYPING = 2 | sig 3 | include LF_SYNTAX 4 | structure LfExn : LF_EXN_UTIL 5 | 6 | structure Inf : 7 | sig 8 | val var : ctx -> var -> class 9 | val rtm : ctx -> rtm -> rclass 10 | end 11 | 12 | structure Chk : 13 | sig 14 | val class : ctx -> class -> unit 15 | val ntm : ctx -> ntm -> class -> unit 16 | val spine : ctx -> spine -> ctx -> unit 17 | val ctx : ctx -> ctx -> unit 18 | end 19 | end -------------------------------------------------------------------------------- /src/refiner/refiner.fun: -------------------------------------------------------------------------------- 1 | functor LfRefiner (R : LF_RULES) : LF_REFINER = 2 | struct 3 | structure Rules = R 4 | open R 5 | 6 | structure LfPrint = LfSyntaxPrint (Lf) 7 | 8 | fun @@ (f, x) = f x 9 | infix @@ 10 | 11 | exception todo fun ?e = raise e 12 | type name_block = Lf.var list 13 | type names = name_block list 14 | 15 | fun mapSnd f (x, y) = 16 | (x, f y) 17 | 18 | fun popName (names : names) : Lf.var * names = 19 | case names of 20 | [] => (Lf.Sym.new (), []) 21 | | [] :: names => mapSnd (fn names' => [] :: names') (popName names) 22 | | (x :: xs) :: names => (x, xs :: names) 23 | 24 | datatype tactic = 25 | RULE of rule 26 | | MT of multitactic 27 | 28 | and multitactic = 29 | ALL of tactic 30 | | EACH of tactic list 31 | | DEBUG of string 32 | | BIND of Rules.Lf.var list * multitactic 33 | | SEQ of multitactic * multitactic 34 | | ORELSE of multitactic * multitactic 35 | 36 | (* The refinement machine has five instructions: 37 | 1. [MTAC mtac] means "run [mtac] on returned proof state" 38 | 2. [AWAIT (x, mtac, st)] means "wait for [x] to emit a proof state, and merge it with [st], and continue executing with [mtac]" 39 | 3. [PREPEND Psi] means "prepend the subgoals Psi onto the returned proof state" 40 | 4. [POP_NAMES] pops a user-supplied name block off the name supply stack 41 | 5. [HANDLE cfg] means "in case of an error, restore the machine state [cfg]" 42 | *) 43 | datatype instr = 44 | MTAC of multitactic 45 | | AWAIT of Lf.var * multitactic * state 46 | | PREPEND of (Lf.var * goal) list 47 | | POP_NAMES 48 | | HANDLE of machine_multi 49 | 50 | withtype stack = instr list 51 | 52 | and machine_focus = {tactic: tactic, goal: goal, stack: stack, names: name_block list} 53 | and machine_multi = {multitactic: multitactic, state: state, stack: stack, names: name_block list} 54 | and machine_retn = {state: state, stack: stack, names: name_block list} 55 | and machine_throw = {exn: exn, goal: goal, trace: stack, stack: stack} 56 | 57 | (* The refinement machine has four execution states: 58 | 1. Executing a tactic on a focused goal 59 | 2. Executing a multitactic on a proof state 60 | 3. Returning a proof state 61 | 4. Throwing an error 62 | *) 63 | datatype machine = 64 | FOCUS of machine_focus 65 | | MULTI of machine_multi 66 | | RETN of machine_retn 67 | | THROW of machine_throw 68 | 69 | datatype 'a step = 70 | STEP of 'a 71 | | FINAL of state 72 | 73 | fun init tac goal = 74 | FOCUS 75 | {tactic = tac, 76 | goal = goal, 77 | stack = [], 78 | names = []} 79 | 80 | open Lf infix \ \\ `@ ==> --> 81 | 82 | structure Goal : 83 | sig 84 | val class : goal -> class 85 | val ctx : (var * goal) list -> ctx 86 | val ren : var Sym.Env.dict -> goal -> goal 87 | val subst : ntm Sym.Env.dict -> goal -> goal 88 | end = 89 | struct 90 | fun class (Psi \ rcl) = 91 | Psi --> rcl 92 | 93 | val ctx : (var * goal) list -> ctx = 94 | List.map (mapSnd class) 95 | 96 | fun subst rho (Psi \ rcl) = 97 | let 98 | val cl = SubstN.class rho (Psi --> rcl) 99 | val Psi' \ rcl' = Unbind.class cl 100 | val (rho', Psi'') = Ren.rebindCtx (List.map #1 Psi) Psi' 101 | in 102 | Psi'' \ Ren.rclass rho' rcl' 103 | end 104 | 105 | fun ren rho (Psi \ rcl) = 106 | let 107 | val cl = Ren.class rho (Psi --> rcl) 108 | val Psi' \ rcl' = Unbind.class cl 109 | val (rho', Psi'') = Ren.rebindCtx (List.map #1 Psi) Psi' 110 | in 111 | Psi'' \ Ren.rclass rho' rcl' 112 | end 113 | end 114 | 115 | fun substState rho (Psi \ evd : state) = 116 | let 117 | val rho' = List.foldr (fn ((x, _), rho) => Sym.Env.remove rho x) rho Psi 118 | val Psi' = map (mapSnd (Goal.subst rho')) Psi 119 | val evd' = SubstN.ntm rho' evd 120 | in 121 | Psi' \ evd' 122 | end 123 | 124 | fun renState rho (Psi \ evd) = 125 | let 126 | val Psi' = map (mapSnd (Goal.ren rho)) Psi 127 | in 128 | Psi' \ Ren.ntm rho evd 129 | end 130 | 131 | structure Print = 132 | struct 133 | fun vars xs = 134 | case xs of 135 | [] => "" 136 | | [x] => Sym.toString x 137 | | x :: xs => Sym.toString x ^ "," ^ vars xs 138 | 139 | fun nameBlocks blocks = 140 | case blocks of 141 | [] => "" 142 | | [xs] => "[" ^ vars xs ^ "]" 143 | | xs :: blocks => "[" ^ vars xs ^ "], " ^ nameBlocks blocks 144 | 145 | fun tactic tac = 146 | case tac of 147 | RULE rl => printRule rl 148 | | MT mtac => multitactic mtac 149 | 150 | and multitactic mtac = 151 | case mtac of 152 | ALL tac => tactic tac 153 | | EACH tacs => "[" ^ tactics tacs ^ "]" 154 | | DEBUG msg => "debug(\"" ^ msg ^ "\")" 155 | | SEQ (mtac1, mtac2) => multitactic mtac1 ^ "; " ^ multitactic mtac2 156 | | ORELSE (mtac1, mtac2) => "{" ^ multitactic mtac1 ^ "} | {" ^ multitactic mtac2 ^ "}" 157 | | BIND (xs, mtac) => "[" ^ vars xs ^ "] <- {" ^ multitactic mtac ^ "}" 158 | 159 | and tactics tacs = 160 | case tacs of 161 | [] => "" 162 | | [tac] => tactic tac 163 | | tac :: tacs => tactic tac ^ ", " ^ tactics tacs 164 | 165 | fun state (Psi \ evd : state) = 166 | LfPrint.ctx (Goal.ctx Psi) 167 | ^ "\n ===> " 168 | ^ LfPrint.ntm evd 169 | 170 | val instr = 171 | fn MTAC mtac => "{" ^ multitactic mtac ^ "}" 172 | | AWAIT (x, mtac, st) => "await[" ^ Sym.toString x ^ "]{" ^ multitactic mtac ^ "}" 173 | | PREPEND Psi => "prepend{" ^ LfPrint.ctx (Goal.ctx Psi) ^ "}" 174 | | POP_NAMES => "pop-names" 175 | | HANDLE _ => "handler" 176 | 177 | fun stack stk = 178 | case stk of 179 | [] => "[]" 180 | | i :: stk => instr i ^ " :: " ^ stack stk 181 | end 182 | 183 | structure Exn = 184 | struct 185 | type refine_error = exn * Lf.class * stack 186 | exception Refine of refine_error 187 | 188 | fun description (exn, goal, stack) = 189 | "[ERROR] " 190 | ^ exnMessage exn 191 | ^ " when refining goal " 192 | ^ LfPrint.class goal 193 | ^ "\n\nStack trace:\n" 194 | ^ Print.stack (List.rev stack) 195 | end 196 | 197 | fun goalToState (goal : goal) : state = 198 | let 199 | val x = Sym.new () 200 | in 201 | [(x, goal)] \ eta (x, Goal.class goal) 202 | end 203 | 204 | fun runRule {ruleName, goal, stack, names} = 205 | let 206 | val namesRef = ref names 207 | fun fresh () = 208 | let 209 | val names = !namesRef 210 | val (x, names') = popName names 211 | in 212 | namesRef := names'; x 213 | end 214 | 215 | val state = rule fresh ruleName goal 216 | in 217 | RETN {state = state, stack = stack, names = !namesRef} 218 | end 219 | handle exn => 220 | THROW 221 | {exn = exn, 222 | goal = goal, 223 | trace = [], 224 | stack = stack} 225 | 226 | fun stepFocus {tactic, goal, stack, names} : machine step = 227 | case tactic of 228 | RULE rl => 229 | STEP o runRule @@ 230 | {ruleName = rl, 231 | goal = goal, 232 | stack = stack, 233 | names = names} 234 | 235 | | MT mtac => 236 | STEP o RETN @@ 237 | {state = goalToState goal, 238 | stack = MTAC mtac :: stack, 239 | names = names} 240 | 241 | fun stepRetn {state as Psi \ evd, stack, names} : machine step = 242 | case stack of 243 | MTAC mtac :: stk => 244 | STEP o MULTI @@ 245 | {multitactic = mtac, 246 | state = state, 247 | stack = stk, 248 | names = names} 249 | 250 | | AWAIT (x, mtac, state) :: stk => 251 | let 252 | val rhox = Sym.Env.singleton x evd 253 | in 254 | STEP o MULTI @@ 255 | {multitactic = mtac, 256 | state = substState rhox state, 257 | stack = PREPEND Psi :: stk, 258 | names = names} 259 | end 260 | 261 | | PREPEND Psi' :: stk => 262 | STEP o RETN @@ 263 | {state = Psi' @ Psi \ evd, 264 | stack = stk, 265 | names = names} 266 | 267 | | HANDLE _ :: stk => 268 | STEP o RETN @@ 269 | {state = state, 270 | stack = stk, 271 | names = names} 272 | 273 | | POP_NAMES :: stk => 274 | STEP o RETN @@ 275 | {state = state, 276 | stack = stk, 277 | names = List.tl names} 278 | 279 | | [] => FINAL state 280 | 281 | fun stepThrow {exn, goal, trace, stack} : machine step = 282 | case stack of 283 | [] => raise Exn.Refine (exn, Goal.class goal, trace) 284 | | HANDLE multi :: stk => STEP @@ MULTI multi 285 | | instr :: stk => 286 | STEP o THROW @@ 287 | {exn = exn, 288 | goal = goal, 289 | trace = instr :: trace, 290 | stack = stk} 291 | 292 | fun debugString msg {state, stack, names} = 293 | "[DEBUG] " ^ msg ^ "\n\n" 294 | ^ "Proof state: \n------------------------------\n" 295 | ^ Print.state state 296 | ^ "\n\nRemaining tasks: \n------------------------------\n" 297 | ^ Print.stack stack 298 | ^ "\n\nName blocks: \n------------------------------\n[" 299 | ^ Print.nameBlocks names 300 | ^ "]\n\n" 301 | 302 | 303 | fun stepMulti (multi as {multitactic, state as Psi \ evd, stack, names}) : machine step = 304 | case (Psi, multitactic) of 305 | (_, DEBUG msg) => 306 | let 307 | val retn = {state = state, stack = stack, names = names} 308 | val debugStr = debugString msg retn 309 | in 310 | print debugStr; 311 | STEP @@ RETN retn 312 | end 313 | 314 | | (_, SEQ (mtac1, mtac2)) => 315 | STEP o MULTI @@ 316 | {multitactic = mtac1, 317 | state = state, 318 | stack = MTAC mtac2 :: stack, 319 | names = names} 320 | 321 | | (_, BIND (xs, mtac)) => 322 | STEP o MULTI @@ 323 | {multitactic = mtac, 324 | state = state, 325 | stack = POP_NAMES :: stack, 326 | names = xs :: names} 327 | 328 | | ([], _) => 329 | STEP o RETN @@ 330 | {state = state, 331 | stack = stack, 332 | names = names} 333 | 334 | | ((x, goal) :: Psi, ALL tac) => 335 | STEP o FOCUS @@ 336 | {tactic = tac, 337 | goal = goal, 338 | stack = AWAIT (x, ALL tac, Psi \ evd) :: stack, 339 | names = names} 340 | 341 | | (_, EACH []) => 342 | STEP o RETN @@ 343 | {state = state, 344 | stack = stack, 345 | names = names} 346 | 347 | | ((x, goal) :: Psi, EACH (tac :: tacs)) => 348 | STEP o FOCUS @@ 349 | {tactic = tac, 350 | goal = goal, 351 | stack = AWAIT (x, EACH tacs, Psi \ evd) :: stack, 352 | names = names} 353 | 354 | | (_, ORELSE (mtac1, mtac2)) => 355 | STEP o MULTI @@ 356 | {multitactic = mtac1, 357 | state = state, 358 | stack = HANDLE multi :: stack, 359 | names = names} 360 | 361 | val step : machine -> machine step = 362 | fn FOCUS foc => stepFocus foc 363 | | MULTI multi => stepMulti multi 364 | | THROW throw => stepThrow throw 365 | | RETN retn => stepRetn retn 366 | 367 | fun eval m = 368 | case step m of 369 | STEP m => eval m 370 | | FINAL st => st 371 | end -------------------------------------------------------------------------------- /src/refiner/refiner.sig: -------------------------------------------------------------------------------- 1 | signature LF_RULES = 2 | sig 3 | structure Lf : LF_TYPING 4 | 5 | type rule 6 | type goal = (Lf.var * Lf.class, Lf.rclass) Lf.bind 7 | type state = (Lf.var * goal, Lf.ntm) Lf.bind 8 | type names = unit -> Lf.var 9 | 10 | val rule : names -> rule -> goal -> state 11 | val printRule : rule -> string 12 | end 13 | 14 | signature LF_REFINER = 15 | sig 16 | structure Rules : LF_RULES 17 | 18 | (* This somewhat nonstandard arrangement of tactics and 19 | multitactics is specifically to support local names for hypotheses 20 | in tactic scripts in the future. Trust Jon Sterling Thought! *) 21 | datatype tactic = 22 | RULE of Rules.rule 23 | | MT of multitactic 24 | 25 | and multitactic = 26 | ALL of tactic 27 | | EACH of tactic list 28 | | DEBUG of string 29 | | BIND of Rules.Lf.var list * multitactic 30 | | SEQ of multitactic * multitactic 31 | | ORELSE of multitactic * multitactic 32 | 33 | structure Exn : 34 | sig 35 | type refine_error 36 | exception Refine of refine_error 37 | val description : refine_error -> string 38 | end 39 | 40 | type machine 41 | val init : tactic -> Rules.goal -> machine 42 | val eval : machine -> Rules.state 43 | end -------------------------------------------------------------------------------- /test/example.sml: -------------------------------------------------------------------------------- 1 | structure Example = 2 | struct 3 | 4 | structure Sg = 5 | struct 6 | datatype constant = 7 | ZE | SU 8 | | EXP | INH | LAM | AP 9 | | NAT | ARR 10 | 11 | val toString = 12 | fn EXP => "exp" 13 | | INH => "inh" 14 | | NAT => "nat" 15 | | ARR => "arr" 16 | | ZE => "ze" 17 | | SU => "su" 18 | | LAM => "lam" 19 | | AP => "ap" 20 | 21 | 22 | val eq : constant * constant -> bool = op= 23 | fun compare (o1, o2) = String.compare (toString o1, toString o2) 24 | end 25 | 26 | structure Sym = LfSymbolWithConstants (Sg) 27 | structure Syn = LfSyntax (Sym) 28 | structure TinyLf = LfTyping (Syn) 29 | 30 | open TinyLf Sym 31 | infix 3 `@ 32 | infixr 2 \ \\ --> ==> 33 | 34 | val Exp = C Sg.EXP `@ [] 35 | 36 | val Ze = C Sg.ZE `@ [] 37 | val Nat = C Sg.NAT `@ [] 38 | fun Su e = C Sg.SU `@ [[] \\ e] 39 | fun Lam (x, e) = C Sg.LAM `@ [[x] \\ e] 40 | fun Inh e = C Sg.INH `@ [[] \\ e] 41 | fun Arr (s, t) = C Sg.ARR `@ [[] \\ s, [] \\ t] 42 | fun Ap (e1, e2) = C Sg.AP `@ [[] \\ e1, [] \\ e2] 43 | 44 | val mySig : ctx = 45 | [(C Sg.EXP, [] ==> TYPE), 46 | (C Sg.INH, [[] ==> `Exp] ==> TYPE), 47 | (C Sg.NAT, [] ==> `Exp), 48 | (C Sg.ZE, [] ==> `Exp), 49 | (C Sg.SU, [[] ==> `Exp] ==> `Exp), 50 | (C Sg.LAM, [[[] ==> `Exp] ==> `Exp] ==> `Exp)] 51 | 52 | structure Rules = 53 | struct 54 | structure Lf = TinyLf 55 | datatype rule = NAT_Z | NAT_S | ARR_I | ARR_E of Lf.var | HYP of Lf.var 56 | val printRule = 57 | fn NAT_Z => "nat/z" 58 | | NAT_S => "nat/s" 59 | | ARR_I => "arr/i" 60 | | ARR_E z => "arr/e[" ^ Lf.Sym.toString z ^ "]" 61 | | HYP x => "hyp[" ^ Lf.Sym.toString x ^ "]" 62 | 63 | type goal = (Lf.var * Lf.class, Lf.rclass) Lf.bind 64 | type state = (Lf.var * goal, Lf.ntm) Lf.bind 65 | type names = unit -> Lf.var 66 | 67 | fun prependHyps (H : ctx) (cl : class) : goal = 68 | let 69 | val Psi \ rcl = Unbind.class cl 70 | in 71 | H @ Psi \ rcl 72 | end 73 | 74 | fun Hyp (z : var) (H \ rcl : goal) = 75 | let 76 | val hypcl = Inf.var H z 77 | val Psi \ rcl' = Unbind.class hypcl 78 | val Psi' = map (fn (x, cl : class) => (x, prependHyps H cl)) Psi 79 | val true = Eq.rclass (rcl, rcl') 80 | in 81 | Psi' \ map #1 H \\ z `@ map (fn (x, H \ rcl) => eta (x, H --> rcl)) Psi' 82 | end 83 | 84 | fun NatZ (H \ `inh) = 85 | let 86 | val C Sg.INH `@ [[] \ C Sg.NAT `@ []] = Unbind.rtm inh 87 | val xs = map #1 (H : ctx) 88 | in 89 | [] \ xs \\ Ze 90 | end 91 | 92 | fun NatS (H \ `inh) = 93 | let 94 | val C Sg.INH `@ [[] \ C Sg.NAT `@ []] = Unbind.rtm inh 95 | val X = Sym.new () 96 | val Psi = [(X, H \ `(Inh Nat))] 97 | in 98 | Psi \ map #1 H \\ Su (X `@ map eta H) 99 | end 100 | 101 | fun ArrI x (H \ `inh) = 102 | let 103 | val C Sg.INH `@ [[] \ arr] = Unbind.rtm inh 104 | val C Sg.ARR `@ [[] \ tyA, [] \ tyB] = Unbind.rtm arr 105 | 106 | val X = Sym.new () 107 | 108 | val Hx = H @ [(x, [] ==> `(Inh tyA))] 109 | val Psi = [(X, Hx \ `(Inh tyB))] 110 | in 111 | Psi \ map #1 H \\ Lam (x, X `@ map eta Hx) 112 | end 113 | 114 | fun ArrE z z' (H \ rcl : goal) = 115 | let 116 | val (H0, hypcl, H1) = Ctx.split H z 117 | val Psi \ ` inh = Unbind.class hypcl 118 | val C Sg.INH `@ [[] \ arr] = Unbind.rtm inh 119 | val C Sg.ARR `@ [[] \ tyA, [] \ tyB] = Unbind.rtm arr 120 | 121 | val x = Sym.new () 122 | val clx = [] ==> `(Inh tyA) 123 | 124 | val z'lam = map #1 Psi \\ Lam (x, z' `@ (map eta Psi @ [eta (x, clx)])) 125 | val rhoz = Sym.Env.singleton z z'lam 126 | val H1' = SubstN.ctx rhoz H1 127 | val rcl' = SubstN.rclass rhoz rcl 128 | 129 | val H' = H0 @ (z, hypcl) :: (z', Psi @ [(x, clx)] --> `(Inh tyB)) :: H1' 130 | 131 | val X = Sym.new () 132 | 133 | val abs = (map #1 Psi @ [x]) \\ Ap (z `@ map eta Psi, x `@ []) 134 | val ns = map eta (H0 @ [(z, hypcl)]) @ abs :: map eta H1' 135 | in 136 | [(X, H' \ rcl')] \ map #1 H' \\ X `@ ns 137 | end 138 | 139 | fun rule fresh = 140 | fn NAT_Z => NatZ 141 | | NAT_S => NatS 142 | | ARR_I => ArrI (fresh ()) 143 | | ARR_E z => ArrE z (fresh ()) 144 | | HYP x => Hyp x 145 | end 146 | 147 | structure Refiner = LfRefiner (Rules) 148 | 149 | fun runMachine {script, goal} = 150 | Refiner.eval (Refiner.init (Refiner.MT script) goal) 151 | 152 | fun test () = 153 | let 154 | open Refiner Rules 155 | 156 | (* SEQ is to THEN as kleisli composition is to kleisli extension. *) 157 | fun sequence [x] = x 158 | | sequence (x :: xs) = SEQ (x, sequence xs) 159 | | sequence [] = EACH [] 160 | 161 | (* BIND pushes a block of user-chosen names for part of a tactic script; when the 162 | sub-script is finished, this block will be popped. Tactics can eat names from outer 163 | blocks. *) 164 | val >>> = BIND 165 | infix >>> 166 | 167 | (* We can elaborate raw terms into proof scripts; here, because typechecking is decidable, 168 | these proof scripts have exactly the same structure as the lambda terms. But for something 169 | like CTT, these elaborated scripts would leave holes (i.e. identity tactics) in certain 170 | places, allowing the user to fill in the details. *) 171 | 172 | fun elaborate r = 173 | case Unbind.rtm r of 174 | C Sg.LAM `@ [[x] \ r] => [x] >>> sequence [ALL (RULE ARR_I), DEBUG "lam", elaborate r] 175 | | C Sg.ZE `@ [] => sequence [ALL (RULE NAT_Z), DEBUG "nat/z"] 176 | | C Sg.SU `@ [[] \ r] => sequence [ALL (RULE NAT_S), DEBUG "nat/s", elaborate r] 177 | (* A fancy elaboration rule which accounts for higher-order hypotheses! Useful in case of funsplit, etc.: *) 178 | | (x as I _) `@ bs => 179 | sequence 180 | [ALL (RULE (HYP x)), 181 | DEBUG "hyp", 182 | EACH (map (fn (xs \ r) => MT (xs >>> elaborate r)) bs)] 183 | 184 | val x = Sym.named "my-var" 185 | val f = Sym.named "f" 186 | 187 | val testElaborate = 188 | {goal = [] \ `(Inh (Arr (Nat, Nat))), 189 | script = elaborate (Lam (x, Su (Su (x `@ []))))} 190 | 191 | val testFunSplit = 192 | {goal = [] \ `(Inh (Arr (Arr (Nat, Nat), Nat))), 193 | script = 194 | [x,f] >>> sequence 195 | [DEBUG "start", 196 | ALL (RULE ARR_I), 197 | DEBUG "arr/i", 198 | ALL (RULE (ARR_E x)), 199 | DEBUG "arr/e", 200 | ALL (RULE (HYP f)), 201 | DEBUG "hyp", 202 | ALL (RULE NAT_S), 203 | DEBUG "su", 204 | ALL (RULE NAT_Z), 205 | DEBUG "ze"]} 206 | in 207 | print ("TESTING ELABORATION\n---------------------\n"); 208 | runMachine testElaborate; 209 | print ("\n\n\nTESTING FUNSPLIT\n---------------------\n"); 210 | runMachine testFunSplit 211 | end 212 | 213 | fun debug x = 214 | LfExn.debug x 215 | handle Refiner.Exn.Refine err => 216 | (print ("\n\n" ^ Refiner.Exn.description err ^ "\n\n"); 217 | raise Refiner.Exn.Refine err) 218 | 219 | val _ = debug test 220 | 221 | end -------------------------------------------------------------------------------- /twelf/lf.elf: -------------------------------------------------------------------------------- 1 | sort : type. 2 | tm : sort -> type. 3 | 4 | => : sort -> sort -> sort. 5 | %infix right 6 =>. 6 | 7 | abs : (tm S -> tm T) -> tm (S => T). 8 | 9 | % A term [J : jdg S] is a judgment which will synthesize evidence of sort [S]. 10 | jdg : sort -> type. 11 | 12 | % hypothetico-general judgments 13 | >> : {J : jdg S} (tm S -> jdg T) -> jdg (S => T). 14 | %infix right 10 >>. 15 | 16 | % [J ~> E] means that [J] is valid, synthesizing evidence [E]. 17 | ~> : jdg S -> tm S -> type. 18 | %infix right 8 ~>. 19 | %mode ~> +J -E. 20 | 21 | % [E <~ J] means that [E] is evidence, namely of [J]. 22 | <~ : tm S -> jdg S -> type. 23 | %infix left 5 <~. 24 | %mode <~ +E -J1. 25 | 26 | fam-unapply : jdg T -> tm S -> (tm S -> jdg T) -> type. 27 | %mode fam-unapply +JT -E -Fam. 28 | 29 | 30 | % The difference between [J ~> E] and [E <~ J] is *mode*. 31 | % When hypothesizing a judgment [J], as below, we add both [J ~> x] 32 | % and [x <~ J] to the context so that we can "remember" what [x] 33 | % was hypothesized to prove in a well-moded way. 34 | 35 | % We provide basic "structural" rules for proofs. 36 | >>/i 37 | : J1 >> J2 ~> abs F 38 | <- {x} 39 | (J1 ~> x) 40 | -> (x <~ J1) 41 | -> fam-unapply (J2 x) x J2 42 | -> J2 x ~> F x. 43 | 44 | 45 | % a basic lambda calculus. 46 | exp : sort. 47 | triv : sort. 48 | 49 | * : tm triv. 50 | 51 | bool : tm exp. 52 | tt : tm exp. 53 | ff : tm exp. 54 | pair : tm exp -> tm exp -> tm exp. 55 | lam : tm (exp => exp) -> tm exp. 56 | ap : tm exp -> tm exp -> tm exp. 57 | dfun : tm exp -> tm (exp => exp) -> tm exp. 58 | dpair : tm exp -> tm (exp => exp) -> tm exp. 59 | fst : tm exp -> tm exp. 60 | snd : tm exp -> tm exp. 61 | 62 | % Now we define two basic refinement judgments: that some term is a type, and that 63 | % some term is an inhabited type. 64 | ty : tm exp -> tm exp -> jdg triv. 65 | eq : tm exp -> tm exp -> tm exp -> jdg triv. 66 | inh : tm exp -> jdg exp. 67 | syn : tm exp -> jdg exp. 68 | dfun-dom : tm exp -> jdg exp. 69 | dfun-cod : tm exp -> jdg (exp => exp). 70 | 71 | dfun-dom/unify 72 | : dfun-dom (dfun A _) ~> A. 73 | 74 | dfun-cod/unify 75 | : dfun-cod (dfun _ B) ~> B. 76 | 77 | ty/bool 78 | : ty bool bool ~> *. 79 | ty/dfun 80 | : ty (dfun A1 (abs B1)) (dfun A2 (abs B2)) ~> * 81 | <- ty A1 A2 ~> _ 82 | <- inh A1 >> ([x] ty (B1 x) (B2 x)) ~> _. 83 | ty/dpair 84 | : ty (dpair A1 (abs B1)) (dpair A2 (abs B2)) ~> * 85 | <- ty A1 A2 ~> _ 86 | <- inh A1 >> ([x] ty (B1 x) (B2 x)) ~> _. 87 | 88 | inh/tt 89 | : inh bool ~> tt. 90 | 91 | inh/ff 92 | : inh bool ~> ff. 93 | 94 | inh/pair 95 | : inh (dpair A (abs B)) ~> pair M N 96 | <- (inh A >> [x] ty (B x) (B x)) ~> _ 97 | <- inh A ~> M 98 | <- inh (B M) ~> N. 99 | 100 | inh/lam 101 | : inh (dfun A (abs B)) ~> lam F 102 | <- ty A A ~> _ 103 | <- inh A >> ([x] inh (B x)) ~> F. 104 | 105 | inh/spread 106 | : inh CZ ~> F (fst Z) (snd Z) 107 | <- fam-unapply (inh CZ) Z C 108 | <- Z <~ inh (dpair A (abs B)) 109 | <- (inh A >> [x] inh (B x) >> [y] C (pair x y)) ~> abs [x] abs [y] F x y. 110 | 111 | eq/tt 112 | : eq bool tt tt ~> *. 113 | eq/ff 114 | : eq bool ff ff ~> *. 115 | eq/pair 116 | : eq (dpair A (abs B)) (pair M1 N1) (pair M2 N2) ~> * 117 | <- (inh A >> [x] ty (B x) (B x)) ~> _ 118 | <- eq A M1 M2 ~> _ 119 | <- eq (B M1) N1 N2 ~> _. 120 | eq/lam 121 | : eq (dfun A (abs B)) (lam (abs F1)) (lam (abs F2)) ~> * 122 | <- inh A >> ([x] eq (B x) (F1 x) (F2 x)) ~> _. 123 | 124 | eq/syn 125 | : eq A M M ~> * 126 | <- syn M ~> A. 127 | 128 | syn/hyp 129 | : syn R ~> A 130 | <- R <~ inh A. 131 | 132 | syn/ap 133 | : syn (ap R M) ~> B M 134 | <- syn R ~> T 135 | <- dfun-dom T ~> A 136 | <- dfun-cod T ~> abs B 137 | <- eq A M M ~> _. 138 | 139 | 140 | %solve test : inh (dfun bool (abs [x] dfun bool (abs [y] bool))) ~> _. 141 | -------------------------------------------------------------------------------- /twelf/sources.cfg: -------------------------------------------------------------------------------- 1 | lf.elf 2 | --------------------------------------------------------------------------------