├── .gitignore ├── README.md ├── README.source.md ├── code-analyzers.lisp ├── compiler-hooks.lisp ├── critic-code-analyzer.lisp ├── notes.txt ├── package.lisp ├── pluggable-types-bid.asd ├── pluggable-types-const.asd ├── pluggable-types-tests.asd ├── pluggable-types.asd ├── pluggable-types.lisp ├── polymorphic-cl-types.asd ├── polymorphic-cl-types.lisp ├── polymorphic-types.asd ├── polymorphic-types.lisp ├── read.lisp ├── tests └── tests.lisp ├── trivia-functions.lisp ├── type-annotations-tests.lisp ├── type-annotations.el ├── type-annotations.lisp ├── type-checker-analyzer.lisp ├── type-checkers ├── bidirectional │ ├── bidirectional.lisp │ ├── package.lisp │ ├── tests.lisp │ ├── type-checker.lisp │ └── util.lisp ├── constraints │ ├── Infer │ │ ├── Makefile │ │ ├── Parser │ │ │ ├── lexer.cmi │ │ │ ├── lexer.cmo │ │ │ ├── lexer.ml │ │ │ ├── lexer.mll │ │ │ ├── parser.cmi │ │ │ ├── parser.cmo │ │ │ ├── parser.ml │ │ │ ├── parser.mli │ │ │ └── parser.mly │ │ ├── ast.cmi │ │ ├── ast.cmo │ │ ├── ast.ml │ │ ├── infer.cmi │ │ ├── infer.cmo │ │ ├── infer.exe │ │ ├── infer.ml │ │ ├── repl.cmi │ │ ├── repl.cmo │ │ ├── repl.ml │ │ ├── unify.cmi │ │ ├── unify.cmo │ │ └── unify.ml │ ├── biunification.lisp │ ├── package.lisp │ ├── tests.lisp │ ├── type-checker.lisp │ ├── unify.lisp │ └── util.lisp └── rel │ ├── README.md │ └── type-inference.scm ├── typechecking.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Implementation of a [pluggable](http://bracha.org/pluggable-types.pdf "Pluggable type systems") [gradual](http://ecee.colorado.edu/~siek/gradualtyping.html "Gradual typing") type system for Common Lisp. 2 | 3 | Status: THIS IS VAPORWARE [AND](http://www.lispworks.com/reference/HyperSpec/Body/a_and.htm) I DON'[T](http://www.lispworks.com/reference/HyperSpec/Body/a_t.htm) KNOW WHAT I'M DOING. 4 | 5 | ## Papers 6 | 7 | * [Gradual Typing for Functional Languages](http://www.cs.colorado.edu/~siek/pubs/pubs/2006/siek06:_gradual.pdf) 8 | * [Pluggable type systems](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.175.1460) 9 | * [Static typing where possible, dynamic typing when needed: the end of the cold war between programming languages](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.69.5966&rep=rep1&type=pdf) 10 | * [Typed Scheme: From Scripts to Programs](http://www.ccs.neu.edu/racket/pubs/dissertation-tobin-hochstadt.pdf) 11 | * [Languages as Libraries](http://www.cs.utah.edu/plt/publications/pldi11-tscff.pdf) 12 | * [Gradual typing for Smalltalk](http://pleiad.cl/research/publications?key=allendeAl-scp2013) 13 | * [Extending Dylan type system for better type inference and error detection](https://www.researchgate.net/publication/228771491_Extending_Dylan's_type_system_for_better_type_inference_and_error_detection) 14 | 15 | ## Other implementations 16 | 17 | * [An optional type system for Clojure](https://github.com/clojure/core.typed) 18 | * [Typed Racket](http://docs.racket-lang.org/ts-guide/) 19 | * [GradualTalk: A Practical Gradual Type System For Smalltalk](http://pleiad.cl/research/software/gradualtalk) 20 | 21 | ## Plan 22 | 23 | 1. Functions typespecs (arity, optional and keyword args, etc) 24 | 2. Add type specs to common-lisp package functions 25 | 3. Try to type a big module (replace :use :cl by :use :gradual) 26 | 4. Tests 27 | 5. CLOS, structs 28 | 6. Polymorphism 29 | 7. Inference 30 | 31 | ## Current implementation 32 | 33 | Here I describe my current approach for an implementation. 34 | 35 | ### Parametric types 36 | 37 | A library of parametric versions of Common Lisp types. The types fallback to 'normal' CL types, so they can be imported and used with no dependency on the pluggable type system. 38 | 39 | For example, the type `list-of`, the parametric version of the [LIST](http://www.lispworks.com/reference/HyperSpec/Body/a_list.htm) type, that takes the type of its elements by parameter. 40 | 41 | It is possible to use them in normal type declarations ([TYPE](http://www.lispworks.com/reference/HyperSpec/Body/a_type.htm) or [FTYPE](http://www.lispworks.com/reference/HyperSpec/Body/d_ftype.htm)), as they get expanded to the equivalent Lisp type. 42 | 43 | (list-of integer) expands to list 44 | 45 | The type parameters are simply ignored in the type definition: 46 | 47 | (deftype list-of (type) 48 | (declare (ignore type)) 49 | 'list) 50 | 51 | Used in a top-level function type: 52 | 53 | (declaim (ftype (function ((list-of string)) string) 54 | my-func)) 55 | 56 | That means that parametric types can be used in code that does not depend on and does not load the `pluggable-types` library. Parameter types won't be checked by Common Lisp type system, but they would still be useful as documentation, and useful for when a pluggable type system is used to check them properly. 57 | 58 | ### Polymorphic types 59 | 60 | Polymorphic types are specified using `all` to bind the type variables. 61 | 62 | For example: 63 | 64 | (declaim (ftype (all (a b) (function ((hash-table-of a b) a) b)) 65 | get-hash)) 66 | 67 | Like with parametric types, polymorphic type variables are expanded to the [T](http://www.lispworks.com/reference/HyperSpec/Body/a_t.htm) type. That means they can be used in normal Common Lisp code without depending on the loading of a typechecking library. 68 | 69 | For instance, the above type gets expanded to the valid Common Lisp type: 70 | 71 | (declaim (ftype (function ((hash-table-of t t) t) t) 72 | get-hash)) 73 | 74 | and `(hash-table-of t t)` expands to `hash-table`, so, the final type is: 75 | 76 | (declaim (ftype (function (hash-table t) t) 77 | get-hash)) 78 | 79 | ### Type checkers 80 | 81 | There are two type checkers at the moment. Both incomplete and incorrect. 82 | Both use `hu.dwim.walker` library to obtain an Abstract Syntax Tree of the Lisp code and walk it. 83 | 84 | #### Constraints 85 | 86 | The `constraints` type checker applies unification to resolve type variables, then generates constraints, and solves them. 87 | 88 | #### Bidirectional 89 | 90 | The `bidirectional` type checker applies syntax-directed type checking. 91 | 92 | ### Compiler hooks 93 | 94 | The typecheckers are hooked into the Lisp compilation workflow via the [compiler-hooks](https://github.com/mmontone/mutils/blob/master/docs/compiler-hooks.md) library. So, after a function or file is compiled, a typechecking is performed if enabled. 95 | 96 | ### Control via declarations 97 | 98 | What gets typechecked or not can be controlled via the `typecheck` [DECLARATION](http://www.lispworks.com/reference/HyperSpec/Body/d_declar.htm). 99 | 100 | It has the following syntax: 101 | 102 | (typecheck enabled? scope) 103 | 104 | where `enabled?` is a boolean, and `scope` one of `:package`, `:file` or the name of a function. 105 | -------------------------------------------------------------------------------- /README.source.md: -------------------------------------------------------------------------------- 1 | Implementation of a [pluggable](http://bracha.org/pluggable-types.pdf "Pluggable type systems") [gradual](http://ecee.colorado.edu/~siek/gradualtyping.html "Gradual typing") type system for Common Lisp. 2 | 3 | Status: THIS IS VAPORWARE AND I DON'T KNOW WHAT I'M DOING. 4 | 5 | ## Papers 6 | 7 | * [Gradual Typing for Functional Languages](http://www.cs.colorado.edu/~siek/pubs/pubs/2006/siek06:_gradual.pdf) 8 | * [Pluggable type systems](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.175.1460) 9 | * [Static typing where possible, dynamic typing when needed: the end of the cold war between programming languages](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.69.5966&rep=rep1&type=pdf) 10 | * [Typed Scheme: From Scripts to Programs](http://www.ccs.neu.edu/racket/pubs/dissertation-tobin-hochstadt.pdf) 11 | * [Languages as Libraries](http://www.cs.utah.edu/plt/publications/pldi11-tscff.pdf) 12 | * [Gradual typing for Smalltalk](http://pleiad.cl/research/publications?key=allendeAl-scp2013) 13 | * [Extending Dylan type system for better type inference and error detection](https://www.researchgate.net/publication/228771491_Extending_Dylan's_type_system_for_better_type_inference_and_error_detection) 14 | 15 | ## Other implementations 16 | 17 | * [An optional type system for Clojure](https://github.com/clojure/core.typed) 18 | * [Typed Racket](http://docs.racket-lang.org/ts-guide/) 19 | * [GradualTalk: A Practical Gradual Type System For Smalltalk](http://pleiad.cl/research/software/gradualtalk) 20 | 21 | ## Plan 22 | 23 | 1. Functions typespecs (arity, optional and keyword args, etc) 24 | 2. Add type specs to common-lisp package functions 25 | 3. Try to type a big module (replace :use :cl by :use :gradual) 26 | 4. Tests 27 | 5. CLOS, structs 28 | 6. Polymorphism 29 | 7. Inference 30 | 31 | ## Current implementation 32 | 33 | Here I describe my current approach for an implementation. 34 | 35 | ### Parametric types 36 | 37 | A library of parametric versions of Common Lisp types. The types fallback to 'normal' CL types, so they can be imported and used with no dependency on the pluggable type system. 38 | 39 | For example, the type `list-of`, the parametric version of the LIST type, that takes the type of its elements by parameter. 40 | 41 | It is possible to use them in normal type declarations (TYPE or FTYPE), as they get expanded to the equivalent Lisp type. 42 | 43 | (list-of integer) expands to list 44 | 45 | The type parameters are simply ignored in the type definition: 46 | 47 | (deftype list-of (type) 48 | (declare (ignore type)) 49 | 'list) 50 | 51 | Used in a top-level function type: 52 | 53 | (declaim (ftype (function ((list-of string)) string) 54 | my-func)) 55 | 56 | That means that parametric types can be used in code that does not depend on and does not load the `pluggable-types` library. Parameter types won't be checked by Common Lisp type system, but they would still be useful as documentation, and useful for when a pluggable type system is used to check them properly. 57 | 58 | ### Polymorphic types 59 | 60 | Polymorphic types are specified using `all` to bind the type variables. 61 | 62 | For example: 63 | 64 | (declaim (ftype (all (a b) (function ((hash-table-of a b) a) b)) 65 | get-hash)) 66 | 67 | Like with parametric types, polymorphic type variables are expanded to the T type. That means they can be used in normal Common Lisp code without depending on the loading of a typechecking library. 68 | 69 | For instance, the above type gets expanded to the valid Common Lisp type: 70 | 71 | (declaim (ftype (function ((hash-table-of t t) t) t) 72 | get-hash)) 73 | 74 | and `(hash-table-of t t)` expands to `hash-table`, so, the final type is: 75 | 76 | (declaim (ftype (function (hash-table t) t) 77 | get-hash)) 78 | 79 | ### Type checkers 80 | 81 | There are two type checkers at the moment. Both incomplete and incorrect. 82 | Both use `hu.dwim.walker` library to obtain an Abstract Syntax Tree of the Lisp code and walk it. 83 | 84 | #### Constraints 85 | 86 | The `constraints` type checker applies unification to resolve type variables, then generates constraints, and solves them. 87 | 88 | #### Bidirectional 89 | 90 | The `bidirectional` type checker applies syntax-directed type checking. 91 | 92 | ### Compiler hooks 93 | 94 | The typecheckers are hooked into the Lisp compilation workflow via the [compiler-hooks](https://github.com/mmontone/mutils/blob/master/docs/compiler-hooks.md) library. So, after a function or file is compiled, a typechecking is performed if enabled. 95 | 96 | ### Control via declarations 97 | 98 | What gets typechecked or not can be controlled via the `typecheck` DECLARATION. 99 | 100 | It has the following syntax: 101 | 102 | (typecheck enabled? scope) 103 | 104 | where `enabled?` is a boolean, and `scope` one of `:package`, `:file` or the name of a function. 105 | -------------------------------------------------------------------------------- /code-analyzers.lisp: -------------------------------------------------------------------------------- 1 | (require :alexandria) 2 | (require :compiler-hooks) 3 | 4 | (defpackage :code-analyzers 5 | (:use :cl :alexandria) 6 | (:export #:code-analyzer 7 | #:analyze 8 | #:analyzers 9 | #:find-code-analyzer 10 | #:*code-analyzers* 11 | #:*code-analyzers-enabled* 12 | #:*debug-code-analyzers* 13 | #:analyze-file 14 | #:analyze-definition 15 | #:read-lisp-file-definitions 16 | #:register-code-analyzer 17 | #:code-analyzer-warning 18 | #:code-analyzer-error 19 | #:analyzer-enabled-p 20 | #:ignored-packages 21 | #:ignored-files 22 | #:ignored-definitions) 23 | (:documentation "Abstract interface for running code analyzers.")) 24 | 25 | (in-package :code-analyzers) 26 | 27 | (defvar *code-analyzers* (make-hash-table) 28 | "The table of available CODE-ANALYZERs.") 29 | 30 | (defvar *code-analyzers-enabled* t 31 | "When enabled, run code analyzers when file and definitions are compiled.") 32 | 33 | (defvar *debug-code-analyzers* nil 34 | "When enabled, errors in the code analyzers are not handled.") 35 | 36 | (defvar *analyzed-file* nil 37 | "Current file being analyzed.") 38 | 39 | (defvar *analyzed-package* nil 40 | "The current package being analyzed.") 41 | 42 | (defvar *ignore-declarations-errors* nil) 43 | 44 | (define-condition code-analyzer-warning (alexandria:simple-style-warning) 45 | ()) 46 | 47 | (define-condition code-analyzer-error (simple-error) 48 | ()) 49 | 50 | (defclass code-analyzer () 51 | ((enabled 52 | :initform t 53 | :type boolean 54 | :accessor analyzer-enabled-p 55 | :documentation "Whether the analyzer is enabled or not.") 56 | (ignored-packages 57 | :initform nil 58 | :type list 59 | :accessor ignored-packages 60 | :documentation "List of packages to ignore by the CODE-ANALYZER.") 61 | (ignored-files 62 | :initform nil 63 | :type list 64 | :accessor ignored-files 65 | :documentation "List of files to be ignored by the CODE-ANALYZER.") 66 | (ignored-definitions 67 | :initform nil 68 | :type list 69 | :accessor ignored-definitions 70 | :documentation "List of function definitions to be ignored by the CODE-ANALYZER.") 71 | (packages 72 | :initform nil 73 | :type list 74 | :accessor packages 75 | :documentation "List of packages to analyze.") 76 | (files 77 | :initform nil 78 | :type list 79 | :accessor files 80 | :documentation "List of files to analyze.") 81 | (definitions 82 | :initform nil 83 | :type list 84 | :accessor definitions 85 | :documentation "List of definitions to analyze.")) 86 | (:documentation "A code analyzer")) 87 | 88 | ;; Use the ANALYZE declaration to control what gets analyzed. 89 | ;; Syntax: (ANALYZE analyzer-name option &rest args) 90 | ;; Default options: 91 | ;; - :analyze, followed by what to analyze. 92 | ;; - :ignore, followed by what to ignore. 93 | (declaim (declaration analyze)) 94 | 95 | (defun condition-message (condition) 96 | "Get the descriptive message of CONDITION." 97 | (with-output-to-string (s) 98 | (write condition :escape nil :stream s))) 99 | 100 | (defun analyzer-warn (error) 101 | (warn (condition-message error))) 102 | 103 | (defun analyzer-error (error) 104 | (error (condition-message error))) 105 | 106 | (defgeneric analyze-definition (analyzer definition) 107 | (:documentation "Use ANALYZER to analyzed DEFINITION.")) 108 | 109 | (defgeneric analyze-file (analyzer file) 110 | (:documentation "Use ANALYZER to analyze FILE. 111 | May want to use READ-LISP-FILE-DEFINITIONS.")) 112 | 113 | (defgeneric process-declaration (analyzer option args) 114 | (:documentation "Process ANALYZE declaration.") 115 | (:method (analyzer option args) 116 | (error "Invalid option: ~s for analyzer: ~a" option analyzer))) 117 | 118 | (declaim (ftype (function (symbol code-analyzer) t) 119 | register-code-analyzer)) 120 | (defun register-code-analyzer (name code-analyzer) 121 | "Register CODE-ANALYZER under NAME." 122 | (setf (gethash (the symbol name) *code-analyzers*) 123 | (the code-analyzer code-analyzer))) 124 | 125 | (defun call-with-analyzer-error-handler (func) 126 | (if *debug-code-analyzers* 127 | (funcall func) 128 | (handler-case 129 | (funcall func) 130 | (error (e) 131 | (warn 'simple-warning 132 | :format-control "Error analyzing: ~a" 133 | :format-arguments (list (condition-message e))))))) 134 | 135 | (defmethod analyze-file ((analyzer code-analyzer) file) 136 | "The default file analyzer. Read the file definitions and invoke ANALYZE-DEFINITION." 137 | (read-lisp-file-definitions 138 | file 139 | (lambda (code) 140 | (unless (or (member file (ignored-files analyzer)) 141 | (and *analyzed-package* 142 | (member *analyzed-package* (ignored-packages analyzer))) 143 | (and (eql (car code) 'defun) 144 | (member (cadr code) (ignored-definitions analyzer)))) 145 | (analyze-definition analyzer code))))) 146 | 147 | (defun should-analyze-p (analyzer thing) 148 | (or (typep analyzer 'controller-code-analyzer) 149 | (etypecase thing 150 | (package 151 | (not (member (package-name thing) (ignored-packages analyzer)))) 152 | (pathname 153 | (not (member thing (ignored-files analyzer)))) 154 | (symbol 155 | (not (member thing (ignored-definitions analyzer))))))) 156 | 157 | (defun find-code-analyzer (name &optional (error-p t)) 158 | "Find a code analyzer by name." 159 | (or (gethash name *code-analyzers*) 160 | (and error-p (error "Code analyzer not available: ~s" name)))) 161 | 162 | (declaim (ftype (function (pathname (or symbol function)) t) 163 | read-lisp-file-edefinitions)) 164 | (defun read-lisp-file-definitions (pathname func) 165 | "General purpose function for reading definitions from a lisp file." 166 | (with-open-file (in pathname) 167 | (let ((eof (list nil))) 168 | (do ((file-position (file-position in) (file-position in)) 169 | (code (read in nil eof) (read in nil eof))) 170 | ((eq code eof) (values)) 171 | (funcall func code))))) 172 | 173 | (defun parse-analyzer-scope (scope) 174 | "Parse elements in SCOPE. 175 | 176 | The elements in SCOPE can be: 177 | - :package, then set to the current package. 178 | - :file, then set to the current file being compiled. 179 | - A symbol, then it is assumed as a function definition name. 180 | - (PACKAGE package-name), then the package with that name. 181 | - A PATHNAME, then the file at that pathname name." 182 | 183 | (let ((packages '()) 184 | (files '()) 185 | (definitions '())) 186 | (dolist (element scope) 187 | (cond 188 | ((and (listp element) 189 | (eql (first element) 'package)) 190 | (push (the symbol (second element)) packages)) 191 | ((eql element :package) 192 | (push (package-name *package*) packages)) 193 | ((pathnamep element) 194 | (push element files)) 195 | ((eql element :file) 196 | (push (the pathname *analyzed-file*) files)) 197 | ((and (symbolp element) 198 | (not (keywordp element))) 199 | (push element definitions)))) 200 | (values definitions files packages))) 201 | 202 | (defmethod process-declaration ((analyzer code-analyzer) 203 | (option (eql :analyze)) 204 | scope) 205 | "Enable analysis for elements in SCOPE. 206 | 207 | The elements in SCOPE can be: 208 | - :package, then set to the current package. 209 | - :file, then set to the current file being compiled. 210 | - A symbol, then it is assumed as a function definition name. 211 | - (PACKAGE package-name), then the package with that name. 212 | - A PATHNAME, then the file at that pathname name. 213 | 214 | Examples: 215 | 216 | (DECLAIM (ANALYZE my-analyzer :analyze :package)) 217 | 218 | (DECLAIM (ANALYZE my-analyzer :analyze (package some-package) (package other-package)))" 219 | 220 | (multiple-value-bind (definitions files packages) 221 | (parse-analyzer-scope scope) 222 | (appendf (packages analyzer) packages) 223 | (appendf (files analyzer) files) 224 | (appendf (definitions analyzer) definitions))) 225 | 226 | (defmethod process-declaration ((analyzer code-analyzer) 227 | (option (eql :ignore)) 228 | scope) 229 | "Disable analysis for elements in SCOPE. 230 | 231 | The elements in SCOPE can be: 232 | - :package, then set to the current package. 233 | - :file, then set to the current file being compiled. 234 | - A symbol, then it is assumed as a function definition name. 235 | - (PACKAGE package-name), then the package with that name. 236 | - A PATHNAME, then the file at that pathname name. 237 | 238 | Examples: 239 | 240 | (DECLAIM (ANALYZE my-analyzer :ignore :package)) 241 | 242 | (DECLAIM (ANALYZE my-analyzer :ignore #p\"some-file.lisp\")))" 243 | 244 | (multiple-value-bind (definitions files packages) 245 | (parse-analyzer-scope scope) 246 | (appendf (ignored-packages analyzer) packages) 247 | (appendf (ignored-files analyzer) files) 248 | (appendf (ignored-definitions analyzer) definitions))) 249 | 250 | ;; The ANALYZERS analyzer controls all analyzers (whether they are enabled or not, debugging, error handling, etc) 251 | ;; Syntax: (ANALYZE ANALYZERS option &rest args) 252 | ;; Options: 253 | ;; - :debug, follwed by a boolean. Affects all analyzers. 254 | ;; - :enabled, follwed by a boolean, and an optional list of analyzers. Affects the passed analyzers, or all analyzers. 255 | 256 | (defclass controller-code-analyzer (code-analyzer) 257 | () 258 | (:documentation "Reads ANALYZE declarations to control CODE-ANALYZERs behaviour.")) 259 | 260 | (defmethod analyze-definition ((analyzer controller-code-analyzer) 261 | code) 262 | (when (and (listp code) 263 | (eql (car code) 'declaim)) 264 | (let ((declarations (cdr code))) 265 | (dolist (declaration declarations) 266 | (when (and (listp declaration) 267 | (eql (car declaration) 'analyze)) 268 | (destructuring-bind (analyze analyzer-name option &rest args) 269 | declaration 270 | (process-declaration (find-code-analyzer analyzer-name) option args))))))) 271 | 272 | (defmethod process-declaration ((analyzer controller-code-analyzer) 273 | (option (eql :enabled)) 274 | value) 275 | (destructuring-bind (enabled-p &rest analyzers) value 276 | (if (null analyzers) 277 | (setf *code-analyzers-enabled* (not (not enabled-p))) 278 | (dolist (analyzer-name analyzers) 279 | (let ((analyzer (find-code-analyzer analyzer-name))) 280 | (setf (analyzer-enabled-p analyzer) (not (not enabled-p)))))))) 281 | 282 | (defmethod process-declaration ((analyzer controller-code-analyzer) 283 | (option (eql :debug)) 284 | value) 285 | (setf *debug-code-analyzers* (not (not (car value))))) 286 | 287 | (register-code-analyzer 'analyzers (make-instance 'controller-code-analyzer)) 288 | 289 | ;; compiler hooks 290 | 291 | (defun analyze-file-hook (file &rest args) 292 | (declare (ignore args)) 293 | ;; Always analyze with a CONTROLLER-CODE-ANALYZER first 294 | (analyze-file (find-code-analyzer 'analyzers) (pathname file)) 295 | ;; Then use 296 | (when *code-analyzers-enabled* 297 | (dolist (analyzer (alexandria:hash-table-values *code-analyzers*)) 298 | (when (and (analyzer-enabled-p analyzer) 299 | (should-analyze-p analyzer (pathname file))) 300 | (analyze-file analyzer file))))) 301 | 302 | (push 'analyze-file-hook compiler-hooks:*after-compile-file-hooks*) 303 | 304 | (provide :code-analyzers) 305 | -------------------------------------------------------------------------------- /compiler-hooks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (defvar *compile-checks* nil 4 | "When enabled, run the type checker when a file or function is compiled.") 5 | 6 | (defvar *debug-compile-checks* nil 7 | "When enabled, type checking errors are not handled.") 8 | 9 | (defvar *type-error-reporter* 'type-check-warn 10 | "The function for reporting a type error.") 11 | 12 | (defvar *ignore-packages* '() 13 | "List of packages to ignore when typechecking.") 14 | 15 | (defvar *ignore-files* '() 16 | "List of files to ignore when typechecking.") 17 | 18 | (defvar *ignore-defs* '() 19 | "The list of function definitions to ignore when typechecking.") 20 | 21 | (defvar *typecheck-packages* '() 22 | "When set, only typecheck packages from this list.") 23 | 24 | (defvar *typeckeck-files* '() 25 | "When set, only typecheck files from this list.") 26 | 27 | ;; Use the TYPECHECK declaration to control what gets typechecked 28 | (declaim (declaration typecheck)) 29 | 30 | (defun type-check-warn (type-error) 31 | (warn (mutils-utils:condition-message type-error))) 32 | 33 | (defun type-check-error (type-error) 34 | (error (mutils-utils:condition-message type-error))) 35 | 36 | (declaim (ftype (function (boolean (or symbol (member :package :file)) &rest t) t) 37 | toggle-typechecking)) 38 | (defun toggle-typechecking (enable what &rest args) 39 | (ecase what 40 | (:package 41 | (if enable 42 | (removef *ignore-packages* (package-name *package*)) 43 | (pushnew (package-name *package*) *ignore-packages*))) 44 | (:file 45 | (if enable 46 | (removef *ignore-files* (the pathname (car args))) 47 | (pushnew (the pathname (car args)) *ignore-files*))) 48 | (t (pushnew (the symbol what) *ignore-defs*)))) 49 | 50 | (defun load-type-declaration (expr file) 51 | "Read and load the type declaration, if EXPR is a type declaration." 52 | (trivia:match expr 53 | ((cons 'eval-when (cons _ forms)) 54 | (mapcar (rcurry #'load-type-declaration file) forms)) 55 | ((cons 'declaim declarations) 56 | (dolist (declaration declarations) 57 | (trivia:match declaration 58 | ((cons 'typecheck args) 59 | (destructuring-bind (toggle &optional (scope :package)) args 60 | (toggle-typechecking toggle scope file))) 61 | ((list (or 'ftype 'ftype*) ftype fname) 62 | (push (cons fname ftype) *funtypes*)) 63 | ((list (or 'type 'type*) type name) 64 | (push (cons name type) *vartypes*))))))) 65 | 66 | (defun call-with-type-error-handler (func) 67 | (if *debug-compile-checks* 68 | (funcall func) 69 | (handler-case 70 | (funcall func) 71 | (type-checking-error (e) 72 | (funcall *type-error-reporter* e)) 73 | (error (e) 74 | (warn 'simple-warning 75 | :format-control "Error typechecking: ~a" 76 | :format-arguments (list (mutils-utils:condition-message e))))))) 77 | 78 | (defun type-check-definition (expr) 79 | "Type check EXPR when appropiate." 80 | (unless (member (package-name *package*) *ignore-packages*) 81 | (trivia:match expr 82 | ((cons 'eval-when (cons _ forms)) 83 | (mapcar #'type-check-definition forms)) 84 | ((list* 'defun fname _) 85 | (unless (member fname *ignore-defs*) 86 | (call-with-type-error-handler 87 | (lambda () (check-form expr)))))))) 88 | 89 | (defun load-file-type-declarations (file &rest args) 90 | (declare (ignore args)) 91 | (read-lisp-file-definitions (pathname file) 92 | (rcurry #'load-type-declaration (pathname file)))) 93 | 94 | (defun check-file-types (file &rest args) 95 | (declare (ignore args)) 96 | (when (and *compile-checks* 97 | (not (member file *ignore-files*))) 98 | (read-lisp-file-definitions (pathname file) #'type-check-definition))) 99 | 100 | (push 'check-file-types compiler-hooks:*after-compile-file-hooks*) 101 | (push 'load-file-type-declarations compiler-hooks:*after-compile-file-hooks*) 102 | -------------------------------------------------------------------------------- /critic-code-analyzer.lisp: -------------------------------------------------------------------------------- 1 | (require :code-analyzers) 2 | (require :lisp-critic) 3 | 4 | (defpackage :critic-code-analyzer 5 | (:use :cl) 6 | (:export :critic 7 | :critic-code-analyzer)) 8 | 9 | (in-package :critic-code-analyzer) 10 | 11 | (defvar *patterns* (lisp-critic::get-pattern-names)) 12 | 13 | (defclass critic-code-analyzer (code-analyzers:code-analyzer) 14 | ()) 15 | 16 | (defun reformat-critique (critique) 17 | "Remove the separators from CRITIQUE." 18 | (with-input-from-string (in critique) 19 | (let ((lines (uiop/stream:slurp-stream-lines in))) 20 | (with-output-to-string (s) 21 | (dolist (line (butlast (rest lines))) 22 | (write-string line s) 23 | (terpri s)))))) 24 | 25 | (defmethod code-analyzers:analyze-definition 26 | ((analyzer critic-code-analyzer) code) 27 | (let ((critique 28 | (with-output-to-string (out) 29 | (lisp-critic::critique-definition code out *patterns*)))) 30 | (unless (zerop (length critique)) 31 | (setq critique (reformat-critique critique)) 32 | ;; TODO: the signaled condition does not contain a source code location. 33 | ;; Would that be possible to add? 34 | (warn 'code-analyzers:code-analyzer-warning :format-control critique)))) 35 | 36 | (code-analyzers:register-code-analyzer 'critic (make-instance 'critic-code-analyzer)) 37 | 38 | (provide :critic-code-analyzer) 39 | -------------------------------------------------------------------------------- /notes.txt: -------------------------------------------------------------------------------- 1 | A possible plan: 2 | - Use standard Lisp declarations. (declaim (ftype ...)) etc.xs 3 | - Use custom declarations. See the DECLARATION declaration. (declaim (declaration my-custom-declaration)). 4 | Could use an type* and ftype* declaration that contain richer type specs, that are consumed by the pluggable type system, and don't affect the program if pluggable types are not used. 5 | - Implement a portable library for obtaining the types of functions (compiler-info library). 6 | - Read definitions from file using READ function. Use a code-walker to parse and typecheck those definitions. 7 | - "Fake" composite types, using deftype and ignoring arguments, but then the typechecker can look at those. Example: (list-of integer). 8 | where: 9 | 10 | (deftype list-of (a) 11 | (declare (ignore a)) 12 | 'list) 13 | 14 | (deftype cons-of (a b) 15 | (declare (ignore a b)) 16 | 'cons) 17 | 18 | Also polymorphic vars: 19 | 20 | (all (x) (function ((list-of x)) x)) 21 | 22 | Problem: the original type spec is not kept, only the macro-expanded. 23 | Possible "solution": re-read the declarations when available and use those, or type-check with the expanded type, badly. 24 | Solution 2: use an alternative implementation of declaim. extensible and keeps the original declaration. 25 | 26 | Consider conditional reader with shadowed declaration symbols: 27 | #+pluggable-types 28 | (declaim (pluggable-types:ftype (all (a) (function (a) boolean)) my-func)) 29 | 30 | The idea is to hook into Common Lisp compilation. There's COMPILE and COMPILE-FILE. COMPILER-HOOKS package replaces the original functions for others that run some hooks. The type checking would run as one of those hooks. When a type error ocurrs, a compiler warning is signaled. swank::call-with-compilation-hooks contains the implementation-specific compiler conditions that should be signaled. 31 | 32 | TODO: 33 | - Read and consider "Type Inference in the Presence of Subtyping: from 34 | Theory to Practice" 35 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage pluggable-types 2 | (:use :cl :anaphora :alexandria 3 | :polymorphic-types :polymorphic-cl-types) 4 | (:export #:typecheck 5 | #:check-form 6 | #:type-checker-check-form 7 | #:type-checker 8 | #:*compile-checks* 9 | #:*debug-compile-checks* 10 | #:*type-error-reporter* 11 | #:type-checking-error 12 | #:type-inconsistency-error)) 13 | -------------------------------------------------------------------------------- /pluggable-types-bid.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :pluggable-types-bid 2 | :author "Mariano Montone " 3 | :version "0.1" 4 | :maintainer "Mariano Montone " 5 | :licence "MIT" 6 | :components 7 | ((:file "trivia-functions") 8 | (:module "type-checkers" 9 | :components 10 | ((:module "bidirectional" 11 | :components 12 | ((:file "package") 13 | (:file "util") 14 | (:file "type-checker") 15 | (:file "bidirectional")))))) 16 | :depends-on (:pluggable-types 17 | :hu.dwim.walker 18 | :trivia 19 | :alexandria 20 | :anaphora 21 | :arrows 22 | :cl-algebraic-data-type)) 23 | -------------------------------------------------------------------------------- /pluggable-types-const.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :pluggable-types-const 2 | :author "Mariano Montone " 3 | :version "0.1" 4 | :maintainer "Mariano Montone " 5 | :licence "MIT" 6 | :components 7 | ((:file "trivia-functions") 8 | (:module "type-checkers" 9 | :components 10 | ((:module "constraints" 11 | :components 12 | ((:file "package") 13 | (:file "util") 14 | (:file "type-checker")))))) 15 | :depends-on (:pluggable-types 16 | :trivia 17 | :hu.dwim.walker 18 | :cl-algebraic-data-type 19 | :arrows)) 20 | -------------------------------------------------------------------------------- /pluggable-types-tests.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :pluggable-types-tests 2 | :author "Mariano Montone " 3 | :version "0.1" 4 | :maintainer "Mariano Montone " 5 | :licence "MIT" 6 | :components 7 | ((:module "tests" 8 | :components ((:file "tests")))) 9 | :depends-on (:pluggable-types :pluggable-types-const :fiasco)) 10 | -------------------------------------------------------------------------------- /pluggable-types.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :pluggable-types 2 | :author "Mariano Montone " 3 | :version "0.1" 4 | :maintainer "Mariano Montone " 5 | :licence "MIT" 6 | :components 7 | ((:file "package") 8 | (:file "pluggable-types") 9 | (:file "util") 10 | (:file "read") 11 | (:file "compiler-hooks") 12 | (:file "code-analyzers") 13 | (:file "type-checker-analyzer")) 14 | :depends-on (:mutils 15 | (:require :mutils-utils) 16 | (:require :compiler-hooks) 17 | (:require :compiler-info) 18 | :trivia 19 | :polymorphic-types 20 | :polymorphic-cl-types)) 21 | -------------------------------------------------------------------------------- /pluggable-types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (defvar *type-checker* nil 4 | "The default type system to use.") 5 | 6 | (defclass type-checker () 7 | ()) 8 | 9 | (defgeneric type-checker-check-form (type-checker form &optional env)) 10 | 11 | (defun check-form (form &key env (type-checker *type-checker*)) 12 | (unless type-checker 13 | (error "No type system selected. Set *TYPE-CHECKER*")) 14 | (type-checker-check-form type-checker form env)) 15 | 16 | (define-condition type-checking-error (simple-error) 17 | ((form :initarg :form 18 | :accessor error-form) 19 | (source :initarg :source 20 | :accessor error-source) 21 | (position :initarg :position 22 | :accessor error-position))) 23 | 24 | (define-condition type-inconsistency-error (type-checking-error) 25 | ()) 26 | -------------------------------------------------------------------------------- /polymorphic-cl-types.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :polymorphic-cl-types 2 | :author "Mariano Montone " 3 | :version "0.1" 4 | :maintainer "Mariano Montone " 5 | :licence "MIT" 6 | :components 7 | ((:file "polymorphic-cl-types"))) 8 | -------------------------------------------------------------------------------- /polymorphic-cl-types.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :polymorphic-cl-types 2 | (:use :cl :polymorphic-types)) 3 | 4 | (in-package :polymorphic-cl-types) 5 | 6 | (declaim (declaration ftype*)) 7 | 8 | (declaim 9 | (ftype* (all (a) (function (a) a)) 10 | identity) 11 | ;; Not possible to type mapcar with monomorphic lists 12 | ;;(ftype* (all (a b) (function ((function (a) b) (list-of a)) (list-of b))) 13 | ;; mapcar) 14 | ;; We can only constrain the return type: 15 | ;;(ftype* (all (b) (function (function (&rest t) b) list &rest list) (list-of b))) 16 | ;; mapcar) 17 | ;; But mapcar can also take a symbol as function, so we cannot do that, 18 | ;; unless we introduce conditionals in types. 19 | (ftype* (case 20 | (all (a b) (function ((function (a) b) (list-of a)) (list-of b))) 21 | (all (b) (function ((function (&rest t) b) list &rest list) (list-of b))) 22 | (function (function list &rest list) list)) 23 | mapcar) 24 | (ftype* (all (a) (function (unsigned-byte (list-of a)) a)) 25 | nth) 26 | (ftype* (all (a) (function ((list-of a)) a)) 27 | first) 28 | (ftype* (all (a) (function ((list-of a)) (list-of a))) 29 | rest) 30 | (ftype* (all (a b) (function ((cons-of a b)) a)) 31 | car) 32 | (ftype* (all (a b) (function ((cons-of a b)) b)) 33 | cdr) 34 | (ftype* (all (a b) (function (a b) (cons-of a b))) 35 | cons) 36 | (ftype* ;;(all (a) (function (&rest a) (list-of a))) 37 | (function (&rest t) list) 38 | list) 39 | (ftype* 40 | (all (a b) 41 | (function (a (alist-of a b) 42 | &key (:test function-designator) 43 | (:test-not function-designator) 44 | (:key function-designator)) 45 | (or b null))) 46 | assoc) 47 | (ftype* (all (a b) (function (a (hash-table-of a b) &optional b) (values (or b null) boolean))) 48 | gethash) 49 | (ftype* (all (b) (function ((function (&rest t) b) &rest t) b)) 50 | funcall)) 51 | -------------------------------------------------------------------------------- /polymorphic-types.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :polymorphic-types 2 | :name "gradual" 3 | :author "Mariano Montone " 4 | :version "0.1" 5 | :maintainer "Mariano Montone " 6 | :licence "MIT" 7 | :components 8 | ((:file "polymorphic-types"))) 9 | -------------------------------------------------------------------------------- /polymorphic-types.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :polymorphic-types 2 | (:use :cl) 3 | (:export 4 | #:all 5 | #:cons-of 6 | #:list-of 7 | #:sequence-of 8 | #:alist 9 | #:alist-of 10 | #:hash-table-of 11 | #:function-name 12 | #:function-designator 13 | #:ftype* 14 | #:type*)) 15 | 16 | (in-package :polymorphic-types) 17 | 18 | (declaim (declaration ftype* type*)) 19 | 20 | (deftype list-of (a) 21 | (declare (ignore a)) 22 | 'list) 23 | 24 | (deftype sequence-of (a) 25 | (declare (ignore a)) 26 | 'sequence) 27 | 28 | (deftype cons-of (a b) 29 | (declare (ignore a b)) 30 | 'cons) 31 | 32 | (deftype optional (a) 33 | `(or ,a null)) 34 | 35 | (deftype alist () 36 | 'list) 37 | 38 | (deftype alist-of (from to) 39 | (declare (ignore from to)) 40 | 'list) 41 | 42 | (deftype hash-table-of (key-type value-type) 43 | (declare (ignore key-type value-type)) 44 | `hash-table) 45 | 46 | ;; Another interesting feature of a pluggable type system, apart from parameterized types, would be to typecheck the functions that are passed as symbols. 47 | 48 | (deftype function-name () 49 | '(and (or symbol 50 | (cons (eql setf) 51 | (cons (and symbol (not (member nil t))) 52 | null))) 53 | (not (member null t)))) 54 | 55 | (deftype function-designator () 56 | '(or function function-name)) 57 | 58 | #|| 59 | 60 | if we strictly followed CLHS, then it should be the following: 61 | 62 | (def (type e) function-designator () 63 | '(or function '(and symbol (not (member nil t))))) 64 | 65 | (def (type e) extended-function-designator () 66 | '(or function function-name)) 67 | 68 | ||# 69 | 70 | (deftype function* (args-types return-type) 71 | (declare (ignore args-types return-type)) 72 | `function-designator) 73 | 74 | (defun subst-all (pairs tree &key key test test-not) 75 | "Substitute all PAIRS of things in TREE. 76 | PAIRS is a list of CONSes, with (old . new)." 77 | (if (null pairs) 78 | tree 79 | (let ((pair (first pairs))) 80 | (apply #'subst 81 | (cdr pair) 82 | (car pair) 83 | (subst-all (rest pairs) tree 84 | :key key :test test :test-not test-not) 85 | (append 86 | (when key 87 | (list :key key)) 88 | (when test 89 | (list :test test)) 90 | (when test-not 91 | (list :test-not test-not))))))) 92 | 93 | (deftype all (args body) 94 | (let ((substs (mapcar (lambda (arg) 95 | (cons arg t)) 96 | args))) 97 | (subst-all substs body))) 98 | 99 | ;; Example type: 100 | (deftype my-type () 101 | `(list-of (cons-of string pathname))) 102 | -------------------------------------------------------------------------------- /read.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (declaim (type (alist-of symbol t) *funtypes*)) 4 | (defvar *funtypes* nil 5 | "Association list of top-level function types. (function-name . function-type)") 6 | (declaim (type (alist-of symbol t) *vartypes*)) 7 | (defvar *vartypes* nil 8 | "Association list of global variables. (varname . vartype)") 9 | 10 | (declaim (ftype* (function (pathname) (values (list-of t) (list-of t))) read-type-declarations-from-file)) 11 | (defun read-type-declarations-from-file (pathname) 12 | (let ((ftypes nil) 13 | (vartypes nil)) 14 | (with-open-file (in pathname) 15 | (let ((eof (list nil))) 16 | (do ((file-position (file-position in) (file-position in)) 17 | (code (read in nil eof) (read in nil eof))) 18 | ((eq code eof) (values)) 19 | (trivia:match code 20 | ((list 'in-package package-name) 21 | (setf *package* (find-package package-name))) 22 | ((cons 'declaim declarations) 23 | (dolist (declaration declarations) 24 | (destructuring-bind (decltype &rest declargs) declaration 25 | (cond 26 | ((member (symbol-name decltype) '("ftype" "ftype*") 27 | :test #'equalp) 28 | (destructuring-bind (ftype fname) declargs 29 | (push (cons fname ftype) ftypes))) 30 | ((member (symbol-name decltype) '("type" "type*") 31 | :test #'equalp) 32 | (destructuring-bind (vartype varname) declargs 33 | (push (cons varname vartype) vartypes))))))))))) 34 | (values (nreverse vartypes) (nreverse ftypes)))) 35 | 36 | (defun load-type-declarations-from-file (pathname) 37 | (multiple-value-bind (vartypes funtypes) 38 | (read-type-declarations-from-file pathname) 39 | (appendf *vartypes* vartypes *vartypes*) 40 | (appendf *funtypes* funtypes *funtypes*) 41 | t)) 42 | 43 | (declaim (ftype (function (pathname function-designator) t) 44 | read-lisp-file-definitions)) 45 | (defun read-lisp-file-definitions (pathname func) 46 | "General purpose function for reading definitions from a lisp file." 47 | (with-open-file (in pathname) 48 | (let ((eof (list nil))) 49 | (do ((file-position (file-position in) (file-position in)) 50 | (code (read in nil eof) (read in nil eof))) 51 | ((eq code eof) (values)) 52 | (funcall func code))))) 53 | 54 | (load-type-declarations-from-file 55 | (probe-file (asdf:system-relative-pathname :pluggable-types "polymorphic-cl-types.lisp"))) 56 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package :pluggable-types/tests 2 | (:use :cl :fiasco :pluggable-types :arrows :polymorphic-types) 3 | (:export #:test-all-type-checkers)) 4 | 5 | (in-package :pluggable-types/tests) 6 | 7 | (defun test-all-type-checkers () 8 | (dolist (type-checker-class (c2mop:class-direct-subclasses (find-class 'pluggable-types::type-checker))) 9 | (let ((pluggable-types::*type-checker* (make-instance (class-name type-checker-class )))) 10 | (fiasco:run-package-tests :package (find-package :pluggable-types/tests))))) 11 | 12 | (defmacro check-is-equalp (form type) 13 | `(is (equalp (check-form ',form) ',type))) 14 | 15 | (defmacro check-is-subtypep (form type) 16 | `(is (subtypep (check-form ',form) ',type))) 17 | 18 | (defmacro check-signals-error (form) 19 | `(signals type-checking-error 20 | (check-form ',form))) 21 | 22 | (deftest check-constant-tests () 23 | (check-is-subtypep 22 number) 24 | (check-is-equalp '(1 2 3) (list-of number))) 25 | 26 | (deftest function-application-tests () 27 | (check-signals-error (+ 22 "lala")) 28 | (check-is-equalp (+ 22 40) (values number &optional))) 29 | 30 | (deftest check-let-tests () 31 | (check-is-subtypep (let ((x "lla")) x) string) 32 | (-> (let ((x 34) 33 | (y 56)) 34 | (+ x (- y x))) 35 | (check-is-subtypep number))) 36 | 37 | (deftest check-parametric-types-test () 38 | ;; Evaluates to integer! : uses the (all (a) (function (a) a)) type !! :-) 39 | (check-is-subtypep (identity 22) number)) 40 | 41 | (deftest check-the-form-test () 42 | (is (equalp (check-form '(the (list-of integer) (list 1 2 3))) 43 | '(list-of integer))) 44 | (signals type-checking-error (check-form '(the (list-of integer) 22))) 45 | (is (equalp (check-form '(the (list-of integer) (list "asdf"))) 46 | '(list-of integer)))) 47 | 48 | (deftest check-parametric-types-test-2 () 49 | (check-is-equalp (mapcar #'+ (the (list-of number) (list 1 2 3))) 50 | (list-of number)) 51 | (check-is-equalp (mapcar #'+ '(1 2 3)) 52 | (list-of number)) 53 | (check-signals-error 54 | (mapcar #'+ (the (list-of string) '("lala" 2 3)))) 55 | (check-is-equalp 56 | (mapcar #'identity (the (list-of string) (list "lala" 2 3))) 57 | (list-of string)) 58 | (check-is-equalp (mapcar #'identity (the (list-of string) (list "lala" 2 3))) 59 | (list-of string)) 60 | (check-is-equalp 61 | (mapcar #'print (the (list-of string) (list "lala"))) 62 | (list-of t)) 63 | 64 | ;; (check-form '(mapcar #'identity (the list '("lala")))) 65 | 66 | ;; (check-form '(mapcar #'identity '("lala"))) 67 | 68 | ;; (check-form '(mapcar #'identity (the (list-of t) '("lala")))) 69 | 70 | (check-is-subtypep (nth 10 (the (list-of string) (list "foo" "bar"))) 71 | string) 72 | (check-signals-error (nth "lala" (the (list-of string) (list "foo" "bar")))) 73 | 74 | (check-is-subtypep 75 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 76 | (nth 1 list)) 77 | string) 78 | 79 | (check-is-subtypep 80 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 81 | (first list)) 82 | string) 83 | 84 | (check-is-subtypep 85 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 86 | (rest list)) 87 | (list-of string))) 88 | 89 | (deftest check-cons-tests () 90 | (check-is-equalp (car (the (cons-of integer string) (cons 2 "lala"))) 91 | integer) 92 | (check-is-equalp (cdr (the (cons-of integer string) (cons 2 "lala"))) 93 | string) 94 | (check-is-subtypep (car (the list '(1 2 3))) 95 | t) 96 | (check-is-subtypep (cdr (the list '(1 2 3))) 97 | list)) 98 | 99 | #+nil(deftest lambda-tests () 100 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 101 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a))) 102 | (check-is-equalp (lambda (x y) (the (cons-of integer string) (cons x y))) 103 | (function (integer string) (cons-of integer string))) 104 | (check-is-equalp (lambda (x y) (cons (1+ x) (string-upcase y))) 105 | (function (number (or string symbol character)) (cons-of number simple-string)))) 106 | 107 | #+nil(deftest type-generalization-tests () 108 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 109 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a)))) 110 | 111 | (deftest setq-tests () 112 | (check-is-equalp 113 | (let ((l (the (list-of (cons-of symbol string)) 114 | (list (cons :lala 22)))) 115 | (x (the symbol 'asdf))) 116 | (setf x (car (nth 0 l)))) 117 | symbol)) 118 | 119 | (deftest hash-table-tests () 120 | (check-is-equalp 121 | (let ((ht (the (hash-table-of symbol string) 122 | (make-hash-table)))) 123 | ht) 124 | (hash-table-of symbol string)) 125 | (check-is-equalp 126 | (let ((ht (the (hash-table-of symbol string) 127 | (make-hash-table)))) 128 | (gethash 'lala ht)) 129 | (values (or string null) boolean)) 130 | (check-signals-error 131 | (let ((ht (the (hash-table-of symbol string) 132 | (make-hash-table)))) 133 | (gethash 22 ht))) 134 | (check-signals-error 135 | (let ((ht (the (hash-table-of symbol string) 136 | (make-hash-table)))) 137 | (+ (gethash 'lala ht) 22)))) 138 | 139 | (defclass my-typed-class () 140 | ((x :initarg :x 141 | :type string) 142 | (y :initarg :y 143 | :type integer))) 144 | 145 | (deftest make-instance-tests () 146 | (check-signals-error (make-instance 'lala)) 147 | 148 | (check-is-equalp (make-instance 'simple-error) simple-error) 149 | 150 | ;; Invalid initargs 151 | (check-signals-error 152 | (make-instance 'simple-error :lala 22)) 153 | 154 | ;; Invalid initargs 155 | (check-signals-error 156 | (make-instance 'my-typed-class :foo 22)) 157 | 158 | ;; Checks initargs type 159 | (check-signals-error 160 | (make-instance 'my-typed-class :x 22)) 161 | 162 | (check-signals-error 163 | (make-instance 'my-typed-class :x nil)) 164 | 165 | (check-is-equalp 166 | (make-instance 'my-typed-class :x "lala") 167 | my-typed-class) 168 | 169 | (check-is-equalp 170 | (make-instance 'my-typed-class :y 22) 171 | my-typed-class)) 172 | 173 | (deftest flet-tests () 174 | (check-is-equalp 175 | (flet ((hello (x) 176 | x)) 177 | (declare (ftype (function (integer) integer) hello)) 178 | (hello 22)) 179 | integer) 180 | 181 | (check-is-equalp 182 | (flet ((hello (x) 183 | x)) 184 | (hello 22)) 185 | t) 186 | 187 | (signals type-checking-error 188 | (check-form '(flet ((hello (x) 189 | x)) 190 | (declare (ftype (function (integer) integer) hello)) 191 | (hello "lala")))) 192 | 193 | (check-is-equalp 194 | (flet ((sum (x y) 195 | (+ x y))) 196 | (declare (ftype (function (integer integer) integer) sum)) 197 | (mapcar #'sum 198 | (the (list-of integer) 199 | (list 1 2 3)) 200 | (the (list-of integer) 201 | (list 3 4 5)))) 202 | (list-of integer)) 203 | 204 | ) 205 | 206 | 207 | ;; Keys test 208 | ;; (declaim (ftype (function (&key (:x integer) (:y integer)) integer) 209 | ;; keys-test)) 210 | ;; (defun keys-test (&key x y) 211 | ;; (+ x y)) 212 | 213 | ;; (defun foo () 214 | ;; (keys-test :x 22 :y "adf")) 215 | 216 | ;; (defun foo () 217 | ;; (keys-test :x 22 :y 44)) 218 | -------------------------------------------------------------------------------- /trivia-functions.lisp: -------------------------------------------------------------------------------- 1 | ;; TODO: it would be desirable to be able to control the order 2 | ;; in which the match-methods patterns are evaluated. 3 | ;; Trivia library patterns in MATCH expressions are also evaluated in 4 | ;; the order they were defined. There's no notion of more/less specific pattern than other. 5 | ;; So, either add an order number to define-match-method, or 6 | ;; implement a more-specific-pattern-p function somehow. 7 | ;; Or both. 8 | 9 | (defpackage :trivia-functions 10 | (:use :cl) 11 | (:export 12 | #:define-match-function 13 | #:define-match-method)) 14 | 15 | (in-package :trivia-functions) 16 | 17 | (defun match-function-methods (fname) 18 | (getf (get fname :trivia-function) :methods)) 19 | 20 | (defmacro define-match-function (fname args) 21 | `(progn 22 | (setf (get ',fname :trivia-function) 23 | (list :args ',args :methods nil)) 24 | (defun ,fname ,args 25 | (dolist (method (match-function-methods ',fname)) 26 | (multiple-value-bind (result matchedp) 27 | (funcall method ,@args) 28 | (when matchedp 29 | (return-from ,fname (values result t)))))))) 30 | 31 | (defmacro define-match-method (fname (pattern &rest args) &body body) 32 | (unless (get fname :trivia-function) 33 | (error "Match function not defined: ~a" fname)) 34 | `(flet ((match-method (pattern-arg ,@args) 35 | (trivia:match pattern-arg 36 | (,pattern (values ,@body t)) 37 | (_ (values nil nil))))) 38 | (push #'match-method (getf (get ',fname :trivia-function) :methods)) 39 | ',fname)) 40 | 41 | ;; (define-match-function match-test (pattern x)) 42 | 43 | ;; (match-test 2 2) 44 | 45 | ;; (define-match-method match-test ("foo" x) 46 | ;; (format nil "foo!! ~a" x)) 47 | 48 | ;; (match-test 2 2) 49 | ;; (match-test "foo" 22) 50 | ;; (match-test '(foo "hello") 40) 51 | 52 | ;; (define-match-method match-test ((list 'foo string) x) 53 | ;; (format nil "foo: ~a. ~a" string x)) 54 | 55 | ;; (match-test '(foo "hello") 40) 56 | -------------------------------------------------------------------------------- /type-annotations-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :type-annotations) 2 | 3 | (tree-remove-if (lambda (x) (eql 'foo x)) '(foo)) 4 | (tree-remove-if (lambda (x) (eql 'foo x)) '(foo foo)) 5 | (tree-remove-if (lambda (x) (eql 'foo x)) '((foo foo))) 6 | (tree-remove-if (lambda (x) (eql 'foo x)) '(x (foo foo))) 7 | (tree-remove-if (lambda (x) (eql 'foo x)) '(x (y foo foo))) 8 | (tree-remove-if #'vectorp '(x #(integer) y #(string))) 9 | 10 | (remove-type-annotations 11 | '(defun hello (x ) 12 | (print "hello"))) 13 | 14 | (remove-type-annotations 15 | '(defun hello (x y ) 16 | (print "hello"))) 17 | 18 | (remove-type-annotations 19 | '(defun hello (x ) 20 | (first x))) 21 | 22 | (remove-type-annotations 23 | '(defun hello (x ) 24 | (first x))) 25 | 26 | (remove-type-annotations 27 | '(defun hello (x &optional (y "lala")) 28 | (first x))) 29 | 30 | 31 | (parse-type-annotations (read-from-string "()")) 32 | (parse-type-annotations (read-from-string "()")) 33 | (parse-type-annotations (read-from-string "(>)")) 34 | (parse-type-annotations (read-from-string "()")) 35 | (parse-type-annotations (read-from-string "(defun hello (x y ) 36 | (print (> 2 3)))")) 37 | (parse-type-annotations (read-from-string "(> 2 3)")) 38 | (parse-type-annotations (read-from-string "(string> 2 3)")) 39 | (parse-type-annotations ') 40 | 41 | 42 | (annotate-defun '(defun my-func (x &optional (y )) x)) 43 | (annotate-defun '(defun my-func (x &optional (y )) x)) 44 | 45 | (annotate-defun '(defun my-func (x &optional (y )) x)) 46 | 47 | (extract-function-types 48 | (annotate-defun 49 | '(defun hello (x )))) 50 | 51 | (extract-function-types 52 | (annotate-defun 53 | '(defun hello (x ) ))) 54 | 55 | (extract-function-types 56 | (annotate-defun 57 | '(defun hello (x y )))) 58 | 59 | (extract-function-types 60 | (annotate-defun 61 | '(defun hello (x y )))) 62 | 63 | (extract-function-types 64 | (annotate-defun 65 | '(defun hello (x y &optional z)))) 66 | 67 | (extract-cl-function-type 68 | (annotate-defun 69 | '(defun hello (x y )))) 70 | 71 | (extract-cl-function-type 72 | (annotate-defun 73 | '(defun hello (x y &optional z)))) 74 | 75 | (extract-cl-function-type 76 | (annotate-defun 77 | '(defun hello (x y &optional z )))) 78 | 79 | (extract-cl-function-type 80 | (annotate-defun 81 | '(defun hello (x y &optional (z t))))) 82 | 83 | (extract-cl-function-type 84 | (annotate-defun 85 | '(defun hello (x y &optional (z t) w)))) 86 | 87 | (extract-cl-function-type 88 | (annotate-defun 89 | '(defun hello (x y &optional (z t) w) ))) 90 | 91 | (extract-cl-function-type 92 | (annotate-defun 93 | '(defun hello (x y &optional (z t) w) ))) 94 | 95 | (extract-cl-function-type 96 | (annotate-defun 97 | '(defun hello (x y &optional (z t) w) 98 | (< 2 4)))) 99 | 100 | (extract-cl-function-type 101 | (annotate-defun 102 | '(defun hello (x y &key (z 'lala) w) 103 | (< 2 4)))) 104 | 105 | (count-ocurrences #\< (symbol-name '>)) 106 | 107 | (extract-return-type '( (print 'lala))) 108 | (extract-return-type '( (print 'lala))) 109 | (extract-return-type '( (print 'lala))) 110 | (parse-type-annotations (extract-return-type '( (print 'lala)))) 111 | 112 | (:defun test1 (x y ) 113 | (+ x y)) 114 | 115 | (:defun test2 (x &key (y 22)) 116 | (+ x y)) 117 | 118 | (:defun test3 (x &rest more ) 119 | (apply #'+ x more)) 120 | 121 | (:defun test3 (x &rest all &key y) 122 | (apply #'+ x all)) 123 | 124 | (:defun test3 (x &key y w ) 125 | (+ x y w)) 126 | 127 | (:defun test3 (x &rest all &key y &allow-other-keys) 128 | (apply #'+ x all)) 129 | 130 | (:defun test3 (x &optional z w ) 131 | (apply #'+ x all)) 132 | 133 | (:defvar *my-hash-table* (make-hash-table) 134 | "My hash table") 135 | -------------------------------------------------------------------------------- /type-annotations.el: -------------------------------------------------------------------------------- 1 | ;; TODO 2 | 3 | ;; Fontify type annotations with font-lock-type-face 4 | 5 | -------------------------------------------------------------------------------- /type-annotations.lisp: -------------------------------------------------------------------------------- 1 | ;;; type-annotations --- Support for inline type annotations. 2 | ;; 3 | ;; Copyright (C) 2023 Mariano Montone. All rights reserved. 4 | ;; 5 | ;; This work is licensed under the terms of the MIT license. 6 | ;; For a copy, see . 7 | ;; 8 | ;; Author: Mariano Montone 9 | ;; Version: 0.1 10 | ;; 11 | ;;; Commentary: 12 | ;; 13 | ;; Support for inline type annotations. 14 | ;; Versions of CL definitions with support for inline type annotations are provided. 15 | ;; Typed DEFUN, DEFVAR, DEFPARAMETER, etc. 16 | ;; 17 | ;; Type annotations appear after variables and arguments names, and are enclosed between sharp brackets, like: ``. 18 | ;; 19 | ;; Usage: 20 | ;; 21 | ;; Use the inline type version of the CL equivalent definer, and inline type annotations: 22 | ;; 23 | ;; (:defun sum (x y ) 24 | ;; (+ x y)) 25 | ;; 26 | ;; Annotated definitions are macro-expanded to top-level type declamations: 27 | ;; 28 | ;; (PROGN 29 | ;; (DECLAIM (FTYPE (FUNCTION (INTEGER INTEGER) INTEGER) SUM)) 30 | ;; (COMMON-LISP:DEFUN SUM (X Y) (+ X Y))) 31 | ;; 32 | ;;; Code: 33 | 34 | (defpackage :type-annotations 35 | (:nicknames :) 36 | (:use :cl) 37 | (:shadow #:defun #:flet 38 | #:defvar #:defparameter) 39 | (:export 40 | #:defun 41 | #:flet 42 | #:defvar 43 | #:defparameter)) 44 | 45 | (in-package :type-annotations) 46 | 47 | (cl:defun tree-remove-if (predicate tree) 48 | (if (atom tree) 49 | (if (funcall predicate tree) 50 | nil 51 | tree) 52 | (let ((car (tree-remove-if predicate (car tree))) 53 | (cdr (tree-remove-if predicate (cdr tree)))) 54 | (if (null car) 55 | cdr 56 | (cons car cdr))))) 57 | 58 | (defstruct type-annotation 59 | type) 60 | 61 | (cl:defun remove-type-annotations (annotated-def) 62 | (destructuring-bind (def name annotated-args &body annotated-body) 63 | annotated-def 64 | `(,def ,name ,(tree-remove-if #'type-annotation-p annotated-args) 65 | ,@(if (type-annotation-p (first annotated-body)) 66 | (rest annotated-body) 67 | annotated-body)))) 68 | 69 | (cl:defun parse-type-annotations (list-of-symbols) 70 | ;; This is the hack for parsing the annotations syntax 71 | ;; Replace #\< by '#S(type-annotation :type ' 72 | ;; and #\> by #\), that closes the type-annotation expression. 73 | ;; For instance, '' is replaced to '#s(type-annotation :type 'integer)'. 74 | ;; Then READ-FROM-STRING is used to obtain the type-annotation structures. 75 | (let* ((str (prin1-to-string list-of-symbols)) 76 | (str (ppcre:regex-replace-all "\\<" str "#S(TYPE-ANNOTATIONS::TYPE-ANNOTATION :TYPE (")) 77 | (str (ppcre:regex-replace-all ">" str "))"))) 78 | (read-from-string str))) 79 | 80 | (cl:defun annotate-defun (defun) 81 | (destructuring-bind (defun name args &body body) 82 | defun 83 | (multiple-value-bind (return-type actual-body) 84 | (extract-return-type body) 85 | (list* defun name (parse-type-annotations args) 86 | return-type 87 | actual-body)))) 88 | 89 | (cl:defun cl-type (type-annotation) 90 | (let ((cl-type (type-annotation-type type-annotation))) 91 | (if (and (listp cl-type) (null (cdr cl-type))) 92 | (car cl-type) 93 | cl-type))) 94 | 95 | (cl:defun extract-function-types (annotated-defun) 96 | (let ((status :required) 97 | (arg-position :arg) 98 | (required '()) 99 | (required-types '()) 100 | (optional '()) 101 | (optional-types '()) 102 | (key '()) 103 | (key-types '()) 104 | (rest nil) 105 | (rest-type (make-type-annotation :type 't)) 106 | (allow-other-keys nil)) 107 | (cl:flet ((complete-types () 108 | ;; If at type position, then complete the types with T type 109 | (when (eql arg-position :type) 110 | (ecase status 111 | (:required (push (make-type-annotation :type 't) required-types)) 112 | (:optional (push (make-type-annotation :type 't) optional-types)) 113 | (:rest nil) 114 | (:key (push (make-type-annotation :type 't) key-types)) 115 | (:allow-other-keys nil))))) 116 | (destructuring-bind (defun name args return-type &body body) annotated-defun 117 | (declare (ignore defun name body)) 118 | (dolist (arg args) args 119 | (block next 120 | (when (eql arg '&optional) 121 | (complete-types) 122 | (setf status :optional) 123 | (setf arg-position :arg) 124 | (return-from next)) 125 | (when (eql arg '&key) 126 | (complete-types) 127 | (setf status :key) 128 | (setf arg-position :arg) 129 | (return-from next)) 130 | (when (eql arg '&rest) 131 | (complete-types) 132 | (setf status :rest) 133 | (setf arg-position :arg) 134 | (return-from next)) 135 | (when (eql arg '&allow-other-keys) 136 | (complete-types) 137 | (setf status :allow-other-keys) 138 | (setf arg-position :arg) 139 | (setf allow-other-keys t)) 140 | (ecase status 141 | (:required 142 | (ecase arg-position 143 | (:arg 144 | (push arg required) 145 | (setf arg-position :type)) 146 | (:type 147 | (if (not (type-annotation-p arg)) 148 | (progn 149 | (push (make-type-annotation :type 't) required-types) 150 | (push arg required)) 151 | (progn 152 | (push arg required-types) 153 | (setf arg-position :arg)))))) 154 | (:optional 155 | (tagbody retry 156 | (ecase arg-position 157 | (:arg 158 | (cond 159 | ((atom arg) 160 | (push arg optional) 161 | (setf arg-position :type)) 162 | ((listp arg) 163 | (push (first arg) optional) 164 | (let ((type 165 | (find-if #'type-annotation-p arg))) 166 | (if type 167 | (push type optional-types) 168 | (push (make-type-annotation :type 't) optional-types)))))) 169 | (:type 170 | (when (not (type-annotation-p arg)) 171 | (push (make-type-annotation :type 't) optional-types) 172 | (setf arg-position :arg) 173 | (go retry)) 174 | (push arg optional-types) 175 | (setf arg-position :arg))))) 176 | (:key 177 | (tagbody retry 178 | (ecase arg-position 179 | (:arg 180 | (cond 181 | ((atom arg) 182 | (push arg key)) 183 | ((listp arg) 184 | (push (first arg) key) 185 | (let ((type 186 | (find-if #'type-annotation-p arg))) 187 | (if type 188 | (push type key-types) 189 | (push (make-type-annotation :type 't) key-types))))) 190 | (setf arg-position :type)) 191 | (:type 192 | (when (not (type-annotation-p arg)) 193 | (push (make-type-annotation :type 't) key-types) 194 | (setf arg-position :arg) 195 | (go retry)) 196 | (push arg key-types) 197 | (setf arg-position :arg))))) 198 | (:rest (ecase arg-position 199 | (:arg 200 | (setf rest arg) 201 | (setf arg-position :type)) 202 | (:type 203 | (when (type-annotation-p arg) 204 | (setf rest-type arg)) 205 | (setf arg-position :arg)))) 206 | (:allow-other-keys)))) 207 | (complete-types) 208 | (values (mapcar #'cons 209 | (reverse required) 210 | (reverse required-types)) 211 | (mapcar #'cons 212 | (reverse optional) 213 | (reverse optional-types)) 214 | (when rest (cons rest rest-type)) 215 | (mapcar #'cons 216 | (reverse key) 217 | (reverse key-types)) 218 | allow-other-keys return-type))))) 219 | 220 | (cl:defun make-keyword (symbol) 221 | (intern (string-upcase (string symbol)) :keyword)) 222 | 223 | (cl:defun extract-cl-function-type (annotated-defun) 224 | (multiple-value-bind (required optional rest key allow-other-keys return) 225 | (extract-function-types annotated-defun) 226 | `(function (,@(mapcar (alexandria:compose #'cl-type #'cdr) required) 227 | ,@(when optional 228 | (list* '&optional (mapcar (alexandria:compose #'cl-type #'cdr) optional))) 229 | ,@(when rest 230 | (list '&rest (cl-type (cdr rest)))) 231 | ,@(when key 232 | (list* '&key (mapcar (lambda (keyarg) 233 | (list (make-keyword (car keyarg)) 234 | (cl-type (cdr keyarg)))) 235 | key))) 236 | ,@(when allow-other-keys 237 | (list '&allow-other-keys))) 238 | ,(cl-type return)))) 239 | 240 | (cl:defun count-ocurrences (what sequence) 241 | (loop with count := 0 242 | for x across sequence 243 | when (eql x what) 244 | do (incf count) 245 | finally (return count))) 246 | 247 | (cl:defun extract-return-type (body) 248 | (let ((first (first body))) 249 | (if (or (null body) 250 | (not (symbolp first)) 251 | (member first '(< <=)) 252 | (not (find #\< (symbol-name first)))) 253 | (values (make-type-annotation :type 't) body) 254 | ;; else, a symbol that starts a type annotation 255 | (let* ((rest-body body) 256 | (symbol (pop rest-body)) 257 | (count 0) 258 | (return-type (list symbol))) 259 | (incf count (count-ocurrences #\< (symbol-name symbol))) 260 | (decf count (count-ocurrences #\> (symbol-name symbol))) 261 | (loop while (and (not (zerop count)) 262 | rest-body) 263 | do 264 | (setf symbol (pop rest-body)) 265 | (push symbol return-type) 266 | (when (symbolp symbol) 267 | (incf count (count-ocurrences #\< (symbol-name symbol))) 268 | (decf count (count-ocurrences #\> (symbol-name symbol))))) 269 | (values (first (parse-type-annotations (reverse return-type))) 270 | rest-body))))) 271 | 272 | (defmacro defun (name args &body body) 273 | "Typed annotated DEFUN. 274 | 275 | Type annotations can appear after argument names. 276 | Annotations on all required, optional and key arguments are supported. 277 | Also, an optional return type annotation can appear after the function arguments list. 278 | 279 | Example: 280 | 281 | (:defun sum (x y ) 282 | (+ x y)) 283 | 284 | The macro is expanded to a top-level type declamation plus a normal DEFUN: 285 | 286 | (PROGN 287 | (DECLAIM (FTYPE (FUNCTION (INTEGER INTEGER) INTEGER) SUM)) 288 | (COMMON-LISP:DEFUN SUM (X Y) (+ X Y))) 289 | " 290 | (let* ((annotated-def (annotate-defun `(defun ,name ,args ,@body))) 291 | (function-type (extract-cl-function-type annotated-def)) 292 | (untyped-definition (remove-type-annotations annotated-def))) 293 | `(progn 294 | (declaim (ftype ,function-type ,name)) 295 | ,(destructuring-bind (defun name args &body body) untyped-definition 296 | (declare (ignore defun)) 297 | `(cl:defun ,name ,args ,@body))))) 298 | 299 | (defmacro defvar (name &rest init) 300 | "Type annotated DEFVAR. 301 | 302 | A type annotation is accepted after the variable name. 303 | 304 | Example: 305 | 306 | (:defvar *my-var* 22) 307 | 308 | The macro is expanded to a top-level type declamation plus a normal DEFVAR: 309 | 310 | (PROGN (DECLAIM (TYPE INTEGER *MY-VAR*)) 311 | (COMMON-LISP:DEFVAR *MY-VAR* 22)) 312 | " 313 | (let ((annot-init (parse-type-annotations init))) 314 | (if (type-annotation-p (car annot-init)) 315 | `(progn 316 | (declaim (type ,(cl-type (car annot-init)) ,name)) 317 | (cl:defvar ,name ,@(rest annot-init))) 318 | `(cl:defvar ,name ,@annot-init)))) 319 | 320 | (defmacro defparameter (name &rest init) 321 | "Type annotated DEFPARAMETER. 322 | 323 | A type annotation is accepted after the variable name. 324 | 325 | Example: 326 | 327 | (:defparameter *my-var* 22) 328 | 329 | The macro is expanded to a top-level type declamation plus a normal DEFPARAMETER: 330 | 331 | (PROGN (DECLAIM (TYPE INTEGER *MY-VAR*)) 332 | (COMMON-LISP:DEFPARAMETER *MY-VAR* 22)) 333 | " 334 | (let ((annot-init (parse-type-annotations init))) 335 | (if (type-annotation-p (car annot-init)) 336 | `(progn 337 | (declaim (type ,(cl-type (car annot-init)) ,name)) 338 | (cl:defparameter ,name ,@(rest annot-init))) 339 | `(cl:defparameter ,name ,@annot-init)))) 340 | 341 | (provide :type-annotations) 342 | -------------------------------------------------------------------------------- /type-checker-analyzer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (defclass type-checker-analyzer (code-analyzers:code-analyzer) 4 | ((type-checker :initarg :type-checker 5 | :accessor type-checker 6 | :initform *type-checker* 7 | :type (or null type-checker)))) 8 | 9 | (defun load-type-declaration (expr file) 10 | "Read and load the type declaration, if EXPR is a type declaration." 11 | (trivia:match expr 12 | ((cons 'eval-when (cons _ forms)) 13 | (mapcar (rcurry #'load-type-declaration file) forms)) 14 | ((cons 'declaim declarations) 15 | (dolist (declaration declarations) 16 | (trivia:match declaration 17 | ((cons 'typecheck args) 18 | (destructuring-bind (toggle &optional (scope :package)) args 19 | (toggle-typechecking toggle scope file))) 20 | ((list (or 'ftype 'ftype*) ftype fname) 21 | (push (cons fname ftype) *funtypes*)) 22 | ((list (or 'type 'type*) type name) 23 | (push (cons name type) *vartypes*))))))) 24 | 25 | (defun type-check-definition (expr analyzer) 26 | "Type check EXPR when appropiate." 27 | (let ((type-checker (or (type-checker analyzer) 28 | *type-checker*))) 29 | (when type-checker 30 | (unless (member (package-name *package*) (code-analyzers:ignored-packages analyzer)) 31 | (trivia:match expr 32 | ((cons 'eval-when (cons _ forms)) 33 | (mapcar #'type-check-definition forms analyzer)) 34 | ((list* 'defun fname _) 35 | (unless (member fname (code-analyzers:ignored-definitions analyzer)) 36 | (call-with-type-error-handler 37 | (lambda () (check-form expr :env nil :type-checker type-checker)))))))))) 38 | 39 | (defmethod code-analyzers:analyze-file ((analyzer type-checker-analyzer) 40 | file) 41 | ;; First load type declarations 42 | (code-analyzers:read-lisp-file-definitions (pathname file) 43 | (rcurry #'load-type-declaration (pathname file))) 44 | ;; Then check types 45 | (code-analyzers:read-lisp-file-definitions (pathname file) 46 | (rcurry #'type-check-definition analyzer))) 47 | 48 | (code-analyzers:register-code-analyzer 49 | 'type-checker (make-instance 'type-checker-analyzer)) 50 | -------------------------------------------------------------------------------- /type-checkers/bidirectional/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :pluggable-types/bid 2 | (:use :cl :alexandria :hu.dwim.walker :polymorphic-types 3 | :pluggable-types) 4 | (:export #:bidirectional-type-checker)) 5 | -------------------------------------------------------------------------------- /type-checkers/bidirectional/tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package :pluggable-types/bid/tests 2 | (:use :cl :fiasco :pluggable-types/bid :arrows :polymorphic-types)) 3 | 4 | (in-package :pluggable-types/bid/tests) 5 | 6 | (defmacro check-is-equalp (form type) 7 | `(is (equalp (check-form ',form) ',type))) 8 | 9 | (defmacro check-is-subtypep (form type) 10 | `(is (types-compatible-p (check-form ',form) ',type))) 11 | 12 | (defmacro check-signals-error (form) 13 | `(signals type-checking-error 14 | (check-form ',form))) 15 | 16 | (deftest check-constant-tests () 17 | (check-is-subtypep 22 number) 18 | (check-is-equalp '(1 2 3) (list-of number))) 19 | 20 | (deftest function-application-tests () 21 | (check-signals-error (+ 22 "lala")) 22 | (check-is-equalp (+ 22 40) (values number &optional))) 23 | 24 | (deftest check-let-tests () 25 | (check-is-subtypep (let ((x "lla")) x) string) 26 | (-> (let ((x 34) 27 | (y 56)) 28 | (+ x (- y x))) 29 | (check-is-subtypep number))) 30 | 31 | (deftest check-parametric-types-test () 32 | ;; Evaluates to integer! : uses the (all (a) (function (a) a)) type !! :-) 33 | (check-is-subtypep (identity 22) number)) 34 | 35 | (deftest check-the-form-test () 36 | (is (equalp (check-form '(the (list-of integer) '(1 2 3))) 37 | '(list-of integer))) 38 | (signals type-checking-error (check-form '(the (list-of integer) 22))) 39 | (is (equalp (check-form '(the (list-of integer) '("asdf"))) 40 | '(list-of integer)))) 41 | 42 | (deftest check-parametric-types-test-2 () 43 | (check-is-equalp (mapcar #'+ (the (list-of number) '(1 2 3))) 44 | (list-of number)) 45 | (check-is-equalp (mapcar #'+ '(1 2 3)) 46 | (list-of number)) 47 | (check-signals-error 48 | (mapcar #'+ (the (list-of string) '("lala" 2 3)))) 49 | (check-is-equalp 50 | (mapcar #'identity (the (list-of string) '("lala" 2 3))) 51 | (list-of string)) 52 | (check-is-equalp (mapcar #'identity (the (list-of string) '("lala" 2 3))) 53 | (list-of string)) 54 | (check-is-equalp 55 | (mapcar #'print (the (list-of string) '("lala"))) 56 | (list-of t)) 57 | 58 | ;; (check-form '(mapcar #'identity (the list '("lala")))) 59 | 60 | ;; (check-form '(mapcar #'identity '("lala"))) 61 | 62 | ;; (check-form '(mapcar #'identity (the (list-of t) '("lala")))) 63 | 64 | (check-is-subtypep (nth 10 (the (list-of string) '("foo" "bar"))) 65 | string) 66 | (check-signals-error (nth "lala" (the (list-of string) '("foo" "bar")))) 67 | 68 | (check-is-subtypep 69 | (let ((list (mapcar #'identity (the (list-of string) '("lala"))))) 70 | (nth 1 list)) 71 | string) 72 | 73 | (check-is-subtypep 74 | (let ((list (mapcar #'identity (the (list-of string) '("lala"))))) 75 | (first list)) 76 | string) 77 | 78 | (check-is-subtypep 79 | (let ((list (mapcar #'identity (the (list-of string) '("lala"))))) 80 | (rest list)) 81 | (list-of string))) 82 | 83 | (deftest check-cons-tests () 84 | (check-is-equalp (car (the (cons-of integer string) (cons 2 "lala"))) 85 | integer) 86 | (check-is-equalp (cdr (the (cons-of integer string) (cons 2 "lala"))) 87 | string) 88 | (check-is-subtypep (car (the list '(1 2 3))) 89 | t) 90 | (check-is-subtypep (cdr (the list '(1 2 3))) 91 | list)) 92 | 93 | #+nil(deftest lambda-tests () 94 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 95 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a))) 96 | (check-is-equalp (lambda (x y) (the (cons-of integer string) (cons x y))) 97 | (function (integer string) (cons-of integer string))) 98 | (check-is-equalp (lambda (x y) (cons (1+ x) (string-upcase y))) 99 | (function (number (or string symbol character)) (cons-of number simple-string)))) 100 | 101 | #+nil(deftest type-generalization-tests () 102 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 103 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a)))) 104 | 105 | (deftest setq-tests () 106 | (check-is-equalp 107 | (let ((l (the (list-of (cons-of symbol string)) 108 | (list (cons :lala 22)))) 109 | (x (the symbol 'asdf))) 110 | (setf x (car (nth 0 l)))) 111 | symbol)) 112 | 113 | (deftest hash-table-tests () 114 | (check-is-equalp 115 | (let ((ht (the (hash-table-of symbol string) 116 | (make-hash-table)))) 117 | ht) 118 | (hash-table-of symbol string)) 119 | (check-is-equalp 120 | (let ((ht (the (hash-table-of symbol string) 121 | (make-hash-table)))) 122 | (gethash 'lala ht)) 123 | (values (or string null) boolean)) 124 | (check-signals-error 125 | (let ((ht (the (hash-table-of symbol string) 126 | (make-hash-table)))) 127 | (gethash 22 ht))) 128 | (check-signals-error 129 | (let ((ht (the (hash-table-of symbol string) 130 | (make-hash-table)))) 131 | (+ (gethash 'lala ht) 22)))) 132 | 133 | (defclass my-typed-class () 134 | ((x :initarg :x 135 | :type string) 136 | (y :initarg :y 137 | :type integer))) 138 | 139 | (deftest make-instance-tests () 140 | (check-signals-error (make-instance 'lala)) 141 | 142 | (check-is-equalp (make-instance 'simple-error) simple-error) 143 | 144 | ;; Invalid initargs 145 | (check-signals-error 146 | (make-instance 'simple-error :lala 22)) 147 | 148 | ;; Invalid initargs 149 | (check-signals-error 150 | (make-instance 'my-typed-class :foo 22)) 151 | 152 | ;; Checks initargs type 153 | (check-signals-error 154 | (make-instance 'my-typed-class :x 22)) 155 | 156 | (check-signals-error 157 | (make-instance 'my-typed-class :x nil)) 158 | 159 | (check-is-equalp 160 | (make-instance 'my-typed-class :x "lala") 161 | my-typed-class) 162 | 163 | (check-is-equalp 164 | (make-instance 'my-typed-class :y 22) 165 | my-typed-class)) 166 | 167 | (deftest flet-tests () 168 | (check-is-equalp 169 | (flet ((hello (x) 170 | x)) 171 | (declare (ftype (function (integer) integer) hello)) 172 | (hello 22)) 173 | integer) 174 | 175 | (check-is-equalp 176 | (flet ((hello (x) 177 | x)) 178 | (hello 22)) 179 | t) 180 | 181 | (signals type-checking-error 182 | (check-form '(flet ((hello (x) 183 | x)) 184 | (declare (ftype (function (integer) integer) hello)) 185 | (hello "lala")))) 186 | 187 | (check-is-equalp 188 | (flet ((sum (x y) 189 | (+ x y))) 190 | (declare (ftype (function (integer integer) integer) sum)) 191 | (mapcar #'sum 192 | (the (list-of integer) 193 | (list 1 2 3)) 194 | (the (list-of integer) 195 | (list 3 4 5)))) 196 | (list-of integer)) 197 | 198 | ) 199 | -------------------------------------------------------------------------------- /type-checkers/bidirectional/type-checker.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types/bid) 2 | 3 | (defclass bidirectional-type-checker (type-checker) 4 | ()) 5 | -------------------------------------------------------------------------------- /type-checkers/bidirectional/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types/bid) 2 | 3 | (defun assign-types-from-function-type (function-type args) 4 | "Assign types to the ARGS being passed to the function." 5 | (assert (eql (first function-type) 'function)) 6 | (destructuring-bind (_ arg-types return-type) function-type 7 | (declare (ignore _ return-type)) 8 | (let ((lambda-section '&required) 9 | (assignments) 10 | (args-queue args)) 11 | (dolist (arg-type arg-types) 12 | (block nil 13 | (when (member arg-type '(&optional &key &rest &aux)) 14 | (setf lambda-section arg-type) 15 | (return)) 16 | (case lambda-section 17 | (&required 18 | (let ((arg (pop args-queue))) 19 | (when (null arg) 20 | (error "Not enough arguments")) 21 | (push (cons arg arg-type) assignments))) 22 | (&optional 23 | (let ((arg (pop args-queue))) 24 | (when (null arg) 25 | (return)) 26 | (push (cons arg arg-type) assignments))) 27 | (&key 28 | (if (eql arg-type '&allow-other-keys) 29 | (setq lambda-section '&allow-other-keys) 30 | (destructuring-bind (key type) arg-type 31 | (let ((arg-val (getf args-queue key))) 32 | (when arg-val 33 | (push (cons arg-val type) assignments))) 34 | (alexandria:remove-from-plistf args-queue key)))) 35 | (&allow-other-keys) 36 | (&rest 37 | ;; Consume all the passed args 38 | (dolist (arg args-queue) 39 | (push (cons arg arg-type) 40 | assignments)) 41 | (setf args-queue nil))))) 42 | (unless (null args-queue) 43 | (if (eql lambda-section '&key) 44 | (error "Invalid key arguments in: ~s" args-queue) 45 | (error "Too many arguments"))) 46 | (nreverse assignments)))) 47 | 48 | #| 49 | 50 | (assign-types-from-function-type '(function () t) '()) 51 | (assign-types-from-function-type '(function (number) t) '(x)) 52 | (assign-types-from-function-type '(function (string &optional number) t) 53 | '(x)) 54 | (assign-types-from-function-type '(function (string &optional number) t) 55 | '()) 56 | 57 | (assign-types-from-function-type '(function (string &optional number) t) 58 | '(x y)) 59 | 60 | (assign-types-from-function-type '(function (string &optional number) t) 61 | '(x y z)) 62 | 63 | (assign-types-from-function-type '(function (string &key (:y number)) t) 64 | '(x)) 65 | 66 | (assign-types-from-function-type '(function (string &key (:y number)) t) 67 | '(x :y y)) 68 | 69 | (assign-types-from-function-type '(function (string &key (:y number)) t) 70 | '(x :y y :z "lala")) 71 | 72 | (assign-types-from-function-type '(function (string &key (:y number)) t) 73 | '(x :y y :z "lala")) 74 | 75 | (assign-types-from-function-type '(function (&rest number) t) '(x y z)) 76 | 77 | |# 78 | 79 | ;; Works over a walked application-form 80 | (defun assign-types-from-function-type-2 (function-type application-form) 81 | (declare (type list function-type) 82 | (type application-form application-form)) 83 | (assert (eql (first function-type) 'function)) 84 | (destructuring-bind (_ arg-types return-type) function-type 85 | (declare (ignore _ return-type)) 86 | (let ((lambda-section '&required) 87 | (assignments (list)) 88 | (args-queue (arguments-of application-form)) 89 | (keys-in-plist-format nil)) 90 | (dolist (arg-type arg-types) 91 | (block nil 92 | (when (member arg-type '(&optional &key &rest &aux)) 93 | (setf lambda-section arg-type) 94 | (return)) 95 | (case lambda-section 96 | (&required 97 | (let ((arg (pop args-queue))) 98 | (when (null arg) 99 | (error "Not enough arguments")) 100 | (push (cons arg arg-type) assignments))) 101 | (&optional 102 | (let ((arg (pop args-queue))) 103 | (when (null arg) 104 | (return)) 105 | (push (cons arg arg-type) assignments))) 106 | (&key 107 | (if (eql arg-type '&allow-other-keys) 108 | (setq lambda-section '&allow-other-keys) 109 | (progn 110 | ;; Convert the list of walked-forms to a plist 111 | (when (not keys-in-plist-format) 112 | (setf args-queue (loop for key in args-queue by #'cddr 113 | for value in (rest args-queue) by #'cddr 114 | collect (value-of key) 115 | collect value)) 116 | (setf keys-in-plist-format t)) 117 | (destructuring-bind (key type) arg-type 118 | (let ((arg-val (getf args-queue key))) 119 | (when arg-val 120 | (push (cons arg-val type) assignments))) 121 | (alexandria:remove-from-plistf args-queue key))))) 122 | (&allow-other-keys) 123 | (&rest 124 | ;; Consume all the passed args 125 | (dolist (arg args-queue) 126 | (push (cons arg arg-type) assignments)) 127 | (setf args-queue nil))))) 128 | (unless (null args-queue) 129 | (if (eql lambda-section '&key) 130 | (error "Invalid key arguments in: ~s" args-queue) 131 | (error "Too many arguments"))) 132 | (nreverse assignments)))) 133 | 134 | #| 135 | 136 | (assign-types-from-function-type-2 '(function () t) (walk-form '(foo))) 137 | (assign-types-from-function-type-2 '(function (number) t) (walk-form '(foo x))) 138 | (assign-types-from-function-type-2 '(function (string &optional number) t) 139 | (walk-form '(foo x))) 140 | (assign-types-from-function-type-2 '(function (string &optional number) t) 141 | (walk-form '(foo))) 142 | 143 | (assign-types-from-function-type-2 '(function (string &optional number) t) 144 | (walk-form '(foo x y))) 145 | 146 | (assign-types-from-function-type-2 '(function (string &optional number) t) 147 | (walk-form '(foo x y z))) 148 | 149 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 150 | (walk-form '(foo x))) 151 | 152 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 153 | (walk-form '(foo x :y y))) 154 | 155 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 156 | (walk-form '(foo x :y y :z "lala"))) 157 | 158 | (assign-types-from-function-type '(function (string &key (:y number)) t) 159 | '(x :y y :z "lala")) 160 | 161 | (assign-types-from-function-type-2 '(function (&rest number) t) 162 | (walk-form '(foo x y z))) 163 | 164 | |# 165 | 166 | (defun some-tree (predicate tree) 167 | (cond 168 | ((atom tree) (funcall predicate tree)) 169 | ((listp tree) 170 | (or (funcall predicate tree) 171 | (some (curry #'some-tree predicate) tree))))) 172 | 173 | ;; (some-tree (lambda (x) 174 | ;; (and (listp x) 175 | ;; (eql (car x) 'var))) 176 | ;; '(or (var x))) 177 | 178 | ;; (some-tree (lambda (x) 179 | ;; (and (listp x) 180 | ;; (eql (car x) 'var))) 181 | ;; '(or x z)) 182 | 183 | ;; (defun tree-find-if (predicate tree) 184 | ;; (cond 185 | ;; ((atom tree) 186 | ;; (when (funcall predicate tree) 187 | ;; tree)) 188 | ;; ((listp tree) 189 | ;; (when (funcall predicate tree) 190 | ;; (return-from tree-find-if tree)) 191 | ;; (dolist (x tree) 192 | ;; (when (tree-find-if predicate x) 193 | ;; (return-from tree-find-if x)))) 194 | ;; (t nil))) 195 | 196 | ;; (tree-find-if (lambda (x) 197 | ;; (and (listp x) 198 | ;; (eql (car x) 'var))) 199 | ;; '(or (var x))) 200 | 201 | ;; (tree-find-if (lambda (x) 202 | ;; (and (listp x) 203 | ;; (eql (car x) 'var))) 204 | ;; '(or x z)) 205 | 206 | (defun type-equalp (t1 t2) 207 | (and (subtypep t1 t2) 208 | (subtypep t2 t1))) 209 | 210 | (defun type-coerceablep (t1 t2) 211 | (or (subtypep t1 t2) 212 | (subtypep t2 t1))) 213 | 214 | (defun tree-find (what tree) 215 | (cond 216 | ((eql what tree) 217 | t) 218 | ((atom tree) 219 | nil) 220 | ((consp tree) 221 | (or (tree-find what (car tree)) 222 | (tree-find what (cdr tree)))) 223 | (t nil))) 224 | 225 | (tree-find 'a '(b (a))) 226 | 227 | (defun tree-find-if (predicate tree) 228 | (cond 229 | ((atom tree) 230 | (funcall predicate tree)) 231 | ((consp tree) 232 | (or (tree-find-if predicate (car tree)) 233 | (tree-find-if predicate (cdr tree)))))) 234 | 235 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Makefile: -------------------------------------------------------------------------------- 1 | # Infer makefile 2 | # 3 | # targets are: 4 | # 5 | # all -- rebuild the project (default) 6 | # clean -- remove all objects and executables 7 | 8 | SOURCES = ast.ml Parser/parser.mli Parser/parser.ml Parser/lexer.ml unify.ml infer.ml repl.ml 9 | 10 | .PHONY: all 11 | all: Parser/parser.mli Parser/parser.ml Parser/lexer.ml infer.exe 12 | 13 | .PHONY: clean 14 | clean: 15 | rm -f infer.exe 16 | rm -f Parser/parser.ml Parser/parser.mli Parser/lexer.ml 17 | for X in . Parser; do \ 18 | for Y in cmo cmi output; do \ 19 | rm -f $$X/*.$$Y; \ 20 | done; \ 21 | done 22 | 23 | infer.exe: $(SOURCES) 24 | ocamlc -o infer.exe -g -I Parser str.cma $(SOURCES) 25 | 26 | Parser/parser.mli Parser/parser.ml: Parser/parser.mly ast.ml 27 | ocamlyacc -v Parser/parser.mly 28 | 29 | Parser/lexer.ml: Parser/lexer.mll Parser/parser.ml 30 | ocamllex Parser/lexer.mll 31 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/lexer.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/Parser/lexer.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/lexer.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/Parser/lexer.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/lexer.ml: -------------------------------------------------------------------------------- 1 | # 1 "Parser/lexer.mll" 2 | 3 | open Parser 4 | exception Eof 5 | 6 | # 7 "Parser/lexer.ml" 7 | let __ocaml_lex_tables = { 8 | Lexing.lex_base = 9 | "\000\000\248\255\000\000\250\255\251\255\075\000\160\000\254\255\ 10 | \255\255\235\000\054\001\249\255"; 11 | Lexing.lex_backtrk = 12 | "\255\255\255\255\255\255\255\255\255\255\003\000\003\000\255\255\ 13 | \255\255\003\000\002\000\255\255"; 14 | Lexing.lex_default = 15 | "\255\255\000\000\255\255\000\000\000\000\255\255\255\255\000\000\ 16 | \000\000\255\255\255\255\000\000"; 17 | Lexing.lex_trans = 18 | "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 19 | \000\000\008\000\007\000\000\000\000\000\000\000\000\000\000\000\ 20 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 21 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 22 | \008\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 23 | \004\000\003\000\000\000\000\000\000\000\002\000\000\000\000\000\ 24 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 25 | \000\000\000\000\000\000\000\000\000\000\000\000\011\000\000\000\ 26 | \000\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 27 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 28 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 29 | \005\000\005\000\005\000\000\000\000\000\000\000\000\000\000\000\ 30 | \000\000\005\000\005\000\005\000\005\000\005\000\006\000\005\000\ 31 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 32 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 33 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 34 | \005\000\005\000\005\000\005\000\005\000\000\000\000\000\000\000\ 35 | \000\000\000\000\000\000\000\000\005\000\005\000\005\000\005\000\ 36 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 37 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 38 | \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ 39 | \000\000\000\000\000\000\000\000\005\000\005\000\005\000\005\000\ 40 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 41 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 42 | \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ 43 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 44 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 45 | \005\000\005\000\000\000\000\000\000\000\000\000\000\000\000\000\ 46 | \000\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 47 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 48 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 49 | \005\000\005\000\005\000\000\000\000\000\000\000\000\000\000\000\ 50 | \001\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 51 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 52 | \005\000\005\000\005\000\005\000\005\000\009\000\005\000\005\000\ 53 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 54 | \005\000\005\000\005\000\005\000\005\000\000\000\000\000\000\000\ 55 | \000\000\000\000\000\000\000\000\005\000\005\000\005\000\005\000\ 56 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 57 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 58 | \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ 59 | \000\000\000\000\000\000\000\000\005\000\005\000\005\000\005\000\ 60 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 61 | \005\000\010\000\005\000\005\000\005\000\005\000\005\000\005\000\ 62 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 63 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 64 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\000\ 65 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 66 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 67 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 68 | \005\000\000\000\000\000\000\000\000\000\000\000\000\000\005\000\ 69 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 70 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 71 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 72 | \005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 73 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 74 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 75 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 76 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 77 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 78 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 79 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 80 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 81 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 82 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 83 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 84 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 85 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 86 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 87 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 88 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000"; 89 | Lexing.lex_check = 90 | "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 91 | \255\255\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ 92 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 93 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 94 | \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 95 | \000\000\000\000\255\255\255\255\255\255\000\000\255\255\255\255\ 96 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 97 | \255\255\255\255\255\255\255\255\255\255\255\255\002\000\255\255\ 98 | \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 99 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 100 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 101 | \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ 102 | \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 103 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 104 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 105 | \000\000\000\000\000\000\005\000\005\000\005\000\005\000\005\000\ 106 | \005\000\005\000\005\000\005\000\005\000\255\255\255\255\255\255\ 107 | \255\255\255\255\255\255\255\255\005\000\005\000\005\000\005\000\ 108 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 109 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 110 | \005\000\005\000\005\000\005\000\005\000\005\000\255\255\255\255\ 111 | \255\255\255\255\255\255\255\255\005\000\005\000\005\000\005\000\ 112 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 113 | \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ 114 | \005\000\005\000\005\000\005\000\005\000\005\000\255\255\255\255\ 115 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 116 | \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 117 | \006\000\006\000\255\255\255\255\255\255\255\255\255\255\255\255\ 118 | \255\255\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 119 | \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 120 | \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 121 | \006\000\006\000\006\000\255\255\255\255\255\255\255\255\255\255\ 122 | \000\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 123 | \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 124 | \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ 125 | \006\000\006\000\006\000\009\000\009\000\009\000\009\000\009\000\ 126 | \009\000\009\000\009\000\009\000\009\000\255\255\255\255\255\255\ 127 | \255\255\255\255\255\255\255\255\009\000\009\000\009\000\009\000\ 128 | \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ 129 | \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ 130 | \009\000\009\000\009\000\009\000\009\000\009\000\255\255\255\255\ 131 | \255\255\255\255\255\255\255\255\009\000\009\000\009\000\009\000\ 132 | \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ 133 | \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ 134 | \009\000\009\000\009\000\009\000\009\000\009\000\010\000\010\000\ 135 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 136 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\010\000\ 137 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 138 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 139 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 140 | \010\000\255\255\255\255\255\255\255\255\255\255\255\255\010\000\ 141 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 142 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 143 | \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ 144 | \010\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 145 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 146 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 147 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 148 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 149 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 150 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 151 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 152 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 153 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 154 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 155 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 156 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 157 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 158 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 159 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ 160 | \255\255\255\255\255\255\255\255\255\255\255\255\255\255"; 161 | Lexing.lex_base_code = 162 | ""; 163 | Lexing.lex_backtrk_code = 164 | ""; 165 | Lexing.lex_default_code = 166 | ""; 167 | Lexing.lex_trans_code = 168 | ""; 169 | Lexing.lex_check_code = 170 | ""; 171 | Lexing.lex_code = 172 | ""; 173 | } 174 | 175 | let rec token lexbuf = 176 | __ocaml_lex_token_rec lexbuf 0 177 | and __ocaml_lex_token_rec lexbuf __ocaml_lex_state = 178 | match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with 179 | | 0 -> 180 | # 9 "Parser/lexer.mll" 181 | ( token lexbuf ) 182 | # 183 "Parser/lexer.ml" 183 | 184 | | 1 -> 185 | # 10 "Parser/lexer.mll" 186 | ( EOL ) 187 | # 188 "Parser/lexer.ml" 188 | 189 | | 2 -> 190 | # 11 "Parser/lexer.mll" 191 | ( FUN ) 192 | # 193 "Parser/lexer.ml" 193 | 194 | | 3 -> 195 | let 196 | # 12 "Parser/lexer.mll" 197 | id 198 | # 199 "Parser/lexer.ml" 199 | = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in 200 | # 12 "Parser/lexer.mll" 201 | ( VAR id ) 202 | # 203 "Parser/lexer.ml" 203 | 204 | | 4 -> 205 | # 13 "Parser/lexer.mll" 206 | ( LPAREN ) 207 | # 208 "Parser/lexer.ml" 208 | 209 | | 5 -> 210 | # 14 "Parser/lexer.mll" 211 | ( RPAREN ) 212 | # 213 "Parser/lexer.ml" 213 | 214 | | 6 -> 215 | # 15 "Parser/lexer.mll" 216 | ( IMP ) 217 | # 218 "Parser/lexer.ml" 218 | 219 | | 7 -> 220 | # 16 "Parser/lexer.mll" 221 | ( EOL ) 222 | # 223 "Parser/lexer.ml" 223 | 224 | | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state 225 | 226 | ;; 227 | 228 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | exception Eof 4 | } 5 | 6 | let alphabetic = ['a'-'z' 'A'-'Z'] 7 | let alphanumeric = ['a'-'z' 'A'-'Z' '0'-'9']* 8 | rule token = parse 9 | | [' ' '\t'] { token lexbuf } (* skip blanks *) 10 | | ['\n'] { EOL } 11 | | "fun" { FUN } 12 | | alphabetic alphanumeric as id { VAR id } 13 | | '(' { LPAREN } 14 | | ')' { RPAREN } 15 | | "->" { IMP } 16 | | eof { EOL } 17 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/parser.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/Parser/parser.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/parser.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/Parser/parser.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/parser.ml: -------------------------------------------------------------------------------- 1 | type token = 2 | | VAR of (string) 3 | | LPAREN 4 | | RPAREN 5 | | IMP 6 | | EOL 7 | | FUN 8 | | APP 9 | 10 | open Parsing;; 11 | # 2 "Parser/parser.mly" 12 | open Ast 13 | # 14 "Parser/parser.ml" 14 | let yytransl_const = [| 15 | 258 (* LPAREN *); 16 | 259 (* RPAREN *); 17 | 260 (* IMP *); 18 | 261 (* EOL *); 19 | 262 (* FUN *); 20 | 263 (* APP *); 21 | 0|] 22 | 23 | let yytransl_block = [| 24 | 257 (* VAR *); 25 | 0|] 26 | 27 | let yylhs = "\255\255\ 28 | \001\000\002\000\002\000\002\000\002\000\000\000" 29 | 30 | let yylen = "\002\000\ 31 | \002\000\001\000\004\000\003\000\002\000\002\000" 32 | 33 | let yydefred = "\000\000\ 34 | \000\000\000\000\002\000\000\000\000\000\006\000\000\000\000\000\ 35 | \000\000\001\000\005\000\004\000\000\000\000\000" 36 | 37 | let yydgoto = "\002\000\ 38 | \006\000\011\000" 39 | 40 | let yysindex = "\003\000\ 41 | \013\255\000\000\000\000\013\255\006\255\000\000\000\255\007\255\ 42 | \012\255\000\000\000\000\000\000\013\255\020\255" 43 | 44 | let yyrindex = "\000\000\ 45 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 46 | \000\000\000\000\000\000\000\000\000\000\015\255" 47 | 48 | let yygindex = "\000\000\ 49 | \000\000\255\255" 50 | 51 | let yytablesize = 22 52 | let yytable = "\007\000\ 53 | \003\000\004\000\008\000\001\000\010\000\005\000\009\000\003\000\ 54 | \004\000\012\000\000\000\014\000\005\000\003\000\004\000\013\000\ 55 | \000\000\003\000\005\000\003\000\003\000\004\000" 56 | 57 | let yycheck = "\001\000\ 58 | \001\001\002\001\004\000\001\000\005\001\006\001\001\001\001\001\ 59 | \002\001\003\001\255\255\013\000\006\001\001\001\002\001\004\001\ 60 | \255\255\003\001\006\001\005\001\001\001\002\001" 61 | 62 | let yynames_const = "\ 63 | LPAREN\000\ 64 | RPAREN\000\ 65 | IMP\000\ 66 | EOL\000\ 67 | FUN\000\ 68 | APP\000\ 69 | " 70 | 71 | let yynames_block = "\ 72 | VAR\000\ 73 | " 74 | 75 | let yyact = [| 76 | (fun _ -> failwith "parser") 77 | ; (fun __caml_parser_env -> 78 | let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in 79 | Obj.repr( 80 | # 22 "Parser/parser.mly" 81 | ( _1 ) 82 | # 83 "Parser/parser.ml" 83 | : Ast.expr)) 84 | ; (fun __caml_parser_env -> 85 | let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in 86 | Obj.repr( 87 | # 26 "Parser/parser.mly" 88 | ( Var _1 ) 89 | # 90 "Parser/parser.ml" 90 | : 'expr)) 91 | ; (fun __caml_parser_env -> 92 | let _2 = (Parsing.peek_val __caml_parser_env 2 : string) in 93 | let _4 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in 94 | Obj.repr( 95 | # 27 "Parser/parser.mly" 96 | ( Fun (_2, _4) ) 97 | # 98 "Parser/parser.ml" 98 | : 'expr)) 99 | ; (fun __caml_parser_env -> 100 | let _2 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in 101 | Obj.repr( 102 | # 28 "Parser/parser.mly" 103 | ( _2 ) 104 | # 105 "Parser/parser.ml" 105 | : 'expr)) 106 | ; (fun __caml_parser_env -> 107 | let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in 108 | let _2 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in 109 | Obj.repr( 110 | # 29 "Parser/parser.mly" 111 | ( App (_1, _2) ) 112 | # 113 "Parser/parser.ml" 113 | : 'expr)) 114 | (* Entry main *) 115 | ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) 116 | |] 117 | let yytables = 118 | { Parsing.actions=yyact; 119 | Parsing.transl_const=yytransl_const; 120 | Parsing.transl_block=yytransl_block; 121 | Parsing.lhs=yylhs; 122 | Parsing.len=yylen; 123 | Parsing.defred=yydefred; 124 | Parsing.dgoto=yydgoto; 125 | Parsing.sindex=yysindex; 126 | Parsing.rindex=yyrindex; 127 | Parsing.gindex=yygindex; 128 | Parsing.tablesize=yytablesize; 129 | Parsing.table=yytable; 130 | Parsing.check=yycheck; 131 | Parsing.error_function=parse_error; 132 | Parsing.names_const=yynames_const; 133 | Parsing.names_block=yynames_block } 134 | let main (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = 135 | (Parsing.yyparse yytables 1 lexfun lexbuf : Ast.expr) 136 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/parser.mli: -------------------------------------------------------------------------------- 1 | type token = 2 | | VAR of (string) 3 | | LPAREN 4 | | RPAREN 5 | | IMP 6 | | EOL 7 | | FUN 8 | | APP 9 | 10 | val main : 11 | (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Ast.expr 12 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/Parser/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Ast 3 | %} 4 | 5 | %token VAR 6 | %token LPAREN RPAREN 7 | %token IMP 8 | %token EOL 9 | %token FUN 10 | %token APP 11 | 12 | %nonassoc FUN 13 | %nonassoc VAR LPAREN 14 | %left APP 15 | 16 | %start main /* entry point */ 17 | %type main 18 | 19 | %% 20 | 21 | main: 22 | expr EOL { $1 } 23 | ; 24 | 25 | expr: 26 | | VAR { Var $1 } 27 | | FUN VAR IMP expr %prec FUN { Fun ($2, $4) } 28 | | LPAREN expr RPAREN { $2 } 29 | | expr expr %prec APP { App ($1, $2) } 30 | ; 31 | 32 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/ast.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/ast.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/ast.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/ast.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/ast.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************* 2 | * Abstract syntax trees for lambda expressions and type expressions * 3 | *********************************************************************) 4 | 5 | type id = string 6 | 7 | (* lambda expressions *) 8 | type expr = 9 | | Fun of id * expr 10 | | App of expr * expr 11 | | Var of id 12 | 13 | (* type expressions *) 14 | type typ = 15 | | TVar of id 16 | | Arrow of typ * typ 17 | 18 | (* annotated expressions *) 19 | type aexpr = 20 | | AFun of id * aexpr * typ 21 | | AApp of aexpr * aexpr * typ 22 | | AVar of id * typ 23 | 24 | let rec to_string (e : expr) : string = 25 | match e with 26 | | Var x -> x 27 | | Fun (x, e) -> Printf.sprintf "fun %s -> %s" x (to_string e) 28 | | App (Fun _ as e1, e2) -> Printf.sprintf "%s %s" (protect e1) (protect e2) 29 | | App (e1, e2) -> Printf.sprintf "%s %s" (to_string e1) (protect e2) 30 | 31 | and protect (e : expr) : string = 32 | match e with 33 | | Var x -> x 34 | | _ -> Printf.sprintf "(%s)" (to_string e) 35 | 36 | let rec type_to_string (e : typ) : string = 37 | match e with 38 | | TVar x -> "'" ^ x 39 | | Arrow (Arrow (u, v) as s, t) -> Printf.sprintf "(%s) -> %s" (type_to_string s) (type_to_string t) 40 | | Arrow (s, t) -> Printf.sprintf "%s -> %s" (type_to_string s) (type_to_string t) 41 | 42 | let rec aexpr_to_string (e : aexpr) : string = 43 | match e with 44 | | AVar (x, a) -> Printf.sprintf "(%s:%s)" x (type_to_string a) 45 | | AApp (e1, e2, a) -> Printf.sprintf "((%s %s):%s)" (aexpr_to_string e1) (aexpr_to_string e2) (type_to_string a) 46 | | AFun (x, e, a) -> Printf.sprintf "((Fun %s -> %s):%s)" x (aexpr_to_string e) (type_to_string a) 47 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/infer.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/infer.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/infer.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/infer.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/infer.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/infer.exe -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/infer.ml: -------------------------------------------------------------------------------- 1 | (****************************************** 2 | * Type inference for simple lambda terms * 3 | ******************************************) 4 | 5 | open Ast 6 | 7 | let code = ref (Char.code 'a') 8 | 9 | let reset_type_vars() = code := Char.code 'a' 10 | 11 | let next_type_var() : typ = 12 | let c = !code in 13 | if c > Char.code 'z' then failwith "too many type variables"; 14 | incr code; 15 | TVar (String.make 1 (Char.chr c)) 16 | 17 | let type_of (ae : aexpr) : typ = 18 | match ae with 19 | AVar (_, a) -> a 20 | | AFun (_, _, a) -> a 21 | | AApp (_, _, a) -> a 22 | 23 | (* annotate all subexpressions with types *) 24 | (* bv = stack of bound variables for which current expression is in scope *) 25 | (* fv = hashtable of known free variables *) 26 | let annotate (e : expr) : aexpr = 27 | let (h : (id, typ) Hashtbl.t) = Hashtbl.create 16 in 28 | let rec annotate' (e : expr) (bv : (id * typ) list) : aexpr = 29 | match e with 30 | Var x -> 31 | (* bound variable? *) 32 | (try let a = List.assoc x bv in AVar (x, a) 33 | (* known free variable? *) 34 | with Not_found -> try let a = Hashtbl.find h x in AVar (x, a) 35 | (* unknown free variable *) 36 | with Not_found -> let a = next_type_var() in Hashtbl.add h x a; AVar (x, a)) 37 | | Fun (x, e) -> 38 | (* assign a new type to x *) 39 | let a = next_type_var() in 40 | let ae = annotate' e ((x, a) :: bv) in 41 | AFun (x, ae, Arrow (a, type_of ae)) 42 | | App (e1, e2) -> 43 | AApp (annotate' e1 bv, annotate' e2 bv, next_type_var()) 44 | in annotate' e [] 45 | 46 | (* collect constraints for unification *) 47 | let rec collect (aexprs : aexpr list) (u : (typ * typ) list) : (typ * typ) list = 48 | match aexprs with 49 | [] -> u 50 | | AVar (_, _) :: r -> collect r u 51 | | AFun (_, ae, _) :: r -> collect (ae :: r) u 52 | | AApp (ae1, ae2, a) :: r -> 53 | let (f, b) = (type_of ae1, type_of ae2) in 54 | collect (ae1 :: ae2 :: r) ((f, Arrow (b, a)) :: u) 55 | 56 | (* collect the constraints and perform unification *) 57 | let infer (e : expr) : typ = 58 | reset_type_vars(); 59 | let ae = annotate e in 60 | let cl = collect [ae] [] in 61 | let s = Unify.unify cl in 62 | Unify.apply s (type_of ae) 63 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/repl.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/repl.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/repl.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/repl.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/repl.ml: -------------------------------------------------------------------------------- 1 | (***************************** 2 | * Main read-eval-print loop * 3 | *****************************) 4 | 5 | let parse (s : string) : Ast.expr = 6 | Parser.main Lexer.token (Lexing.from_string s) 7 | 8 | let i = "fun x -> x" 9 | let s = "fun x -> fun y -> fun z -> x z (y z)" 10 | let k = "fun x -> fun y -> x" 11 | let o = "fun f -> fun g -> fun x -> f (g x)" 12 | let y = "fun f -> (fun x -> f x x) (fun y -> f y y)" 13 | 14 | let rec repl () = 15 | print_string "? "; 16 | let input = read_line() in 17 | if input = "" then () else 18 | try 19 | let e = parse input in 20 | let t = Infer.infer e in 21 | Printf.printf "%s : %s\n" (Ast.to_string e) (Ast.type_to_string t); 22 | repl () 23 | with Failure msg -> print_endline msg; repl () 24 | | _ -> print_endline "Error"; repl () 25 | 26 | let _ = repl() 27 | -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/unify.cmi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/unify.cmi -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/unify.cmo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/cl-pluggable-types/7ef26302668a51e12156ff5e2fbc9cd12730e07f/type-checkers/constraints/Infer/unify.cmo -------------------------------------------------------------------------------- /type-checkers/constraints/Infer/unify.ml: -------------------------------------------------------------------------------- 1 | (***************************** 2 | * Unification of type terms * 3 | *****************************) 4 | 5 | open Ast 6 | 7 | (* invariant for substitutions: no id on a lhs occurs in any term earlier *) 8 | (* in the list *) 9 | type substitution = (id * typ) list 10 | 11 | (* check if a variable occurs in a term *) 12 | let rec occurs (x : id) (t : typ) : bool = 13 | match t with 14 | | TVar y -> x = y 15 | | Arrow (u, v) -> occurs x u || occurs x v 16 | 17 | (* substitute term s for all occurrences of var x in term t *) 18 | let rec subst (s : typ) (x : id) (t : typ) : typ = 19 | match t with 20 | | TVar y -> if x = y then s else t 21 | | Arrow (u, v) -> Arrow (subst s x u, subst s x v) 22 | 23 | (* apply a substitution to t right to left *) 24 | let apply (s : substitution) (t : typ) : typ = 25 | List.fold_right (fun (x, e) -> subst e x) s t 26 | 27 | (* unify one pair *) 28 | let rec unify_one (s : typ) (t : typ) : substitution = 29 | match (s, t) with 30 | | (TVar x, TVar y) -> if x = y then [] else [(x, t)] 31 | | (Arrow (x, y), Arrow (u, v)) -> unify [(x, u); (y, v)] 32 | | ((TVar x, (Arrow (u, v) as z)) | ((Arrow (u, v) as z), TVar x)) -> 33 | if occurs x z 34 | then failwith "not unifiable: circularity" 35 | else [(x, z)] 36 | 37 | (* unify a list of pairs *) 38 | and unify (s : (typ * typ) list) : substitution = 39 | match s with 40 | | [] -> [] 41 | | (x, y) :: t -> 42 | let t2 = unify t in 43 | let t1 = unify_one (apply t2 x) (apply t2 y) in 44 | t1 @ t2 45 | 46 | -------------------------------------------------------------------------------- /type-checkers/constraints/biunification.lisp: -------------------------------------------------------------------------------- 1 | ;; Try to implement biunification, a more promising approach. 2 | ;; https://infoscience.epfl.ch/record/278576 3 | ;; https://blog.polybdenum.com/2020/07/04/subtype-inference-by-example-part-1-introducing-cubiml.html 4 | ;; https://lptk.github.io/programming/2020/03/26/demystifying-mlsub.html 5 | ;; https://www.cs.tufts.edu/~nr/cs257/archive/stephen-dolan/thesis.pdf 6 | -------------------------------------------------------------------------------- /type-checkers/constraints/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :pluggable-types/const 2 | (:use 3 | :cl :alexandria :hu.dwim.walker 4 | :pluggable-types 5 | :polymorphic-types 6 | :polymorphic-cl-types) 7 | (:export 8 | #:constraints-type-checker)) 9 | -------------------------------------------------------------------------------- /type-checkers/constraints/tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package :pluggable-types/const/tests 2 | (:use :cl :fiasco :pluggable-types/const :arrows :polymorphic-types)) 3 | 4 | (in-package :pluggable-types/const/tests) 5 | 6 | (defmacro let-ftypes ()) 7 | 8 | (defmacro check-is-equalp (form type) 9 | `(is (equalp (check-form ',form) ',type))) 10 | 11 | (defmacro check-is-subtypep (form type) 12 | `(is (types-compatible-p (check-form ',form) ',type))) 13 | 14 | (defmacro check-signals-error (form) 15 | `(signals type-checking-error 16 | (check-form ',form))) 17 | 18 | (deftest check-constant-tests () 19 | (check-is-subtypep 22 number) 20 | (check-is-equalp '(1 2 3) (list-of number))) 21 | 22 | (deftest function-application-tests () 23 | (check-signals-error (+ 22 "lala")) 24 | (check-is-equalp (+ 22 40) (values number &optional))) 25 | 26 | (deftest check-let-tests () 27 | (check-is-subtypep (let ((x "lla")) x) string) 28 | (-> (let ((x 34) 29 | (y 56)) 30 | (+ x (- y x))) 31 | (check-is-subtypep number))) 32 | 33 | (deftest check-parametric-types-test () 34 | ;; Evaluates to integer! : uses the (all (a) (function (a) a)) type !! :-) 35 | (check-is-subtypep (identity 22) number)) 36 | 37 | (deftest check-the-form-test () 38 | (is (equalp (check-form '(the (list-of integer) (list 1 2 3))) 39 | '(list-of integer))) 40 | (signals type-checking-error (check-form '(the (list-of integer) 22))) 41 | (is (equalp (check-form '(the (list-of integer) (list "asdf"))) 42 | '(list-of integer)))) 43 | 44 | (deftest check-parametric-types-test-2 () 45 | (check-is-equalp (mapcar #'+ (the (list-of number) (list 1 2 3))) 46 | (list-of number)) 47 | (check-is-equalp (mapcar #'+ '(1 2 3)) 48 | (list-of number)) 49 | (check-signals-error 50 | (mapcar #'+ (the (list-of string) '("lala" 2 3)))) 51 | (check-is-equalp 52 | (mapcar #'identity (the (list-of string) (list "lala" 2 3))) 53 | (list-of string)) 54 | (check-is-equalp (mapcar #'identity (the (list-of string) (list "lala" 2 3))) 55 | (list-of string)) 56 | (check-is-equalp 57 | (mapcar #'print (the (list-of string) (list "lala"))) 58 | (list-of t)) 59 | 60 | ;; (check-form '(mapcar #'identity (the list '("lala")))) 61 | 62 | ;; (check-form '(mapcar #'identity '("lala"))) 63 | 64 | ;; (check-form '(mapcar #'identity (the (list-of t) '("lala")))) 65 | 66 | (check-is-subtypep (nth 10 (the (list-of string) (list "foo" "bar"))) 67 | string) 68 | (check-signals-error (nth "lala" (the (list-of string) (list "foo" "bar")))) 69 | 70 | (check-is-subtypep 71 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 72 | (nth 1 list)) 73 | string) 74 | 75 | (check-is-subtypep 76 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 77 | (first list)) 78 | string) 79 | 80 | (check-is-subtypep 81 | (let ((list (mapcar #'identity (the (list-of string) (list "lala"))))) 82 | (rest list)) 83 | (list-of string))) 84 | 85 | (deftest check-cons-tests () 86 | (check-is-equalp (car (the (cons-of integer string) (cons 2 "lala"))) 87 | integer) 88 | (check-is-equalp (cdr (the (cons-of integer string) (cons 2 "lala"))) 89 | string) 90 | (check-is-subtypep (car (the list '(1 2 3))) 91 | t) 92 | (check-is-subtypep (cdr (the list '(1 2 3))) 93 | list)) 94 | 95 | #+nil(deftest lambda-tests () 96 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 97 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a))) 98 | (check-is-equalp (lambda (x y) (the (cons-of integer string) (cons x y))) 99 | (function (integer string) (cons-of integer string))) 100 | (check-is-equalp (lambda (x y) (cons (1+ x) (string-upcase y))) 101 | (function (number (or string symbol character)) (cons-of number simple-string)))) 102 | 103 | #+nil(deftest type-generalization-tests () 104 | (check-is-equalp (lambda (x) x) (all (a) (function (a) a))) 105 | (check-is-equalp (lambda (x y) x) (all (a b) (function (a b) a)))) 106 | 107 | (deftest setq-tests () 108 | (check-is-equalp 109 | (let ((l (the (list-of (cons-of symbol string)) 110 | (list (cons :lala 22)))) 111 | (x (the symbol 'asdf))) 112 | (setf x (car (nth 0 l)))) 113 | symbol)) 114 | 115 | (deftest hash-table-tests () 116 | (check-is-equalp 117 | (let ((ht (the (hash-table-of symbol string) 118 | (make-hash-table)))) 119 | ht) 120 | (hash-table-of symbol string)) 121 | (check-is-equalp 122 | (let ((ht (the (hash-table-of symbol string) 123 | (make-hash-table)))) 124 | (gethash 'lala ht)) 125 | (values (or string null) boolean)) 126 | (check-signals-error 127 | (let ((ht (the (hash-table-of symbol string) 128 | (make-hash-table)))) 129 | (gethash 22 ht))) 130 | (check-signals-error 131 | (let ((ht (the (hash-table-of symbol string) 132 | (make-hash-table)))) 133 | (+ (gethash 'lala ht) 22)))) 134 | 135 | (defclass my-typed-class () 136 | ((x :initarg :x 137 | :type string) 138 | (y :initarg :y 139 | :type integer))) 140 | 141 | (deftest make-instance-tests () 142 | (check-signals-error (make-instance 'lala)) 143 | 144 | (check-is-equalp (make-instance 'simple-error) simple-error) 145 | 146 | ;; Invalid initargs 147 | (check-signals-error 148 | (make-instance 'simple-error :lala 22)) 149 | 150 | ;; Invalid initargs 151 | (check-signals-error 152 | (make-instance 'my-typed-class :foo 22)) 153 | 154 | ;; Checks initargs type 155 | (check-signals-error 156 | (make-instance 'my-typed-class :x 22)) 157 | 158 | (check-signals-error 159 | (make-instance 'my-typed-class :x nil)) 160 | 161 | (check-is-equalp 162 | (make-instance 'my-typed-class :x "lala") 163 | my-typed-class) 164 | 165 | (check-is-equalp 166 | (make-instance 'my-typed-class :y 22) 167 | my-typed-class)) 168 | 169 | (deftest flet-tests () 170 | (check-is-equalp 171 | (flet ((hello (x) 172 | x)) 173 | (declare (ftype (function (integer) integer) hello)) 174 | (hello 22)) 175 | integer) 176 | 177 | (check-is-equalp 178 | (flet ((hello (x) 179 | x)) 180 | (hello 22)) 181 | t) 182 | 183 | (signals type-checking-error 184 | (check-form '(flet ((hello (x) 185 | x)) 186 | (declare (ftype (function (integer) integer) hello)) 187 | (hello "lala")))) 188 | 189 | (check-is-equalp 190 | (flet ((sum (x y) 191 | (+ x y))) 192 | (declare (ftype (function (integer integer) integer) sum)) 193 | (mapcar #'sum 194 | (the (list-of integer) 195 | (list 1 2 3)) 196 | (the (list-of integer) 197 | (list 3 4 5)))) 198 | (list-of integer)) 199 | 200 | ) 201 | 202 | 203 | ;; Keys test 204 | ;; (declaim (ftype (function (&key (:x integer) (:y integer)) integer) 205 | ;; keys-test)) 206 | ;; (defun keys-test (&key x y) 207 | ;; (+ x y)) 208 | 209 | ;; (defun foo () 210 | ;; (keys-test :x 22 :y "adf")) 211 | 212 | ;; (defun foo () 213 | ;; (keys-test :x 22 :y 44)) 214 | -------------------------------------------------------------------------------- /type-checkers/constraints/unify.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types/const) 2 | 3 | ;; https://www.cs.cornell.edu/courses/cs3110/2011sp/Lectures/lec26-type-inference/type-inference.htm 4 | 5 | (defvar *debug-unification* nil 6 | "When enabled, unification steps are printed to *STANDARD-OUTPUT*") 7 | 8 | (define-condition type-unification-error (simple-error) 9 | ()) 10 | 11 | (adt:defdata type-term 12 | (var symbol t) ;; var-name, info 13 | ;; (literal-type t) 14 | ;; (function-type list t t) ;; arg-types, return-type, info 15 | (or-type list) 16 | (accepts-type t)) 17 | 18 | (defmethod print-object ((var var) stream) 19 | (adt:match var var 20 | ((var varname info) 21 | (write-string "(var " stream) 22 | (princ varname stream) 23 | (when info 24 | (write-string " " stream) 25 | (prin1 info stream)) 26 | (write-string ")" stream)))) 27 | 28 | (eval-when (:compile-toplevel :load-toplevel :execute) 29 | (trivia-functions:define-match-function unify-types (types))) 30 | 31 | ;; Homogeneous lists 32 | (trivia-functions:define-match-method unify-types 33 | ((list (list 'list-of elem-type-a) (list 'list-of elem-type-b))) 34 | (unify-one elem-type-a elem-type-b)) 35 | 36 | (trivia-functions:define-match-method unify-types 37 | ((list (list 'list-of list-type) 38 | (list 'cons-of cons-type-a cons-type-b))) 39 | (append (unify-one list-type cons-type-a) 40 | (unify-one cons-type-b `(list-of ,list-type)))) 41 | 42 | (trivia-functions:define-match-method unify-types 43 | ((list (list 'cons-of cons-type-a cons-type-b) 44 | (list 'list-of list-type))) 45 | (append (unify-one list-type cons-type-a) 46 | (unify-one cons-type-b `(list-of ,list-type)))) 47 | 48 | ;; List fallback/coercion 49 | (trivia-functions:define-match-method unify-types 50 | ((or (list (list 'list-of elem-type) (or 'cons 'list)) 51 | (list (or 'cons 'list) (list 'list-of elem-type)))) 52 | (unify-one (list 'list-of elem-type) '(list-of t))) 53 | 54 | ;; Homogeneous cons 55 | (trivia-functions:define-match-method unify-types 56 | ((list (list 'cons-of a b) (list 'cons-of c d))) 57 | (append (unify-one a c) 58 | (unify-one b d))) 59 | 60 | ;; Cons fallback/coercion 61 | (trivia-functions:define-match-method unify-types 62 | ((or (list (list 'cons-of a b) (or 'cons 'list)) 63 | (list (or 'cons 'list) (list 'cons-of a b)))) 64 | (unify-one (list 'cons-of a b) '(cons-of t t))) 65 | 66 | (trivia-functions:define-match-method unify-types 67 | ((list (list 'hash-table-of a b) 68 | (list 'hash-table-of c d))) 69 | (unify-one a c) 70 | (unify-one b d)) 71 | 72 | (defun unify-one (term1 term2) 73 | (format *debug-unification* "Unify: ~a ~a " term1 term2) 74 | (let ((unification 75 | (trivia:match (list term1 term2) 76 | ;; or expression 77 | ((list (or-type (%0 opts)) term) 78 | (handler-case 79 | (unify-one (first opts) term) 80 | (type-unification-error () 81 | (if (null (cdr opts)) 82 | (error 'type-unification-error 83 | :format-control "Can't unify: ~s with: ~s" 84 | :format-arguments (list term1 term2)) 85 | (unify-one (or-type (cdr opts)) term))))) 86 | ((list term (or-type (%0 opts))) 87 | (handler-case 88 | (unify-one term (first opts)) 89 | (type-unification-error () 90 | (if (null (cdr opts)) 91 | (error 'type-unification-error 92 | :format-control "Can't unify: ~s with: ~s" 93 | :format-arguments (list term1 term2)) 94 | (unify-one term (or-type (cdr opts))))))) 95 | ;; type variables 96 | ((list (var (%0 x) (%1 x-info)) (var (%0 y) (%1 y-info))) 97 | (list (cons x (var y y-info)))) 98 | ((list (var (%0 x) (%1 info)) type) 99 | (list (cons x type))) 100 | ((list type (var (%0 x) (%1 info))) 101 | (list (cons x type))) 102 | ;; multiple values unification 103 | ((list (cons 'values values-types-1) 104 | (cons 'values values-types-2)) 105 | (loop for val-type-1 in values-types-1 106 | for val-type-2 in values-types-2 107 | appending (unify-one val-type-1 val-type-2))) 108 | ((list (cons 'values values-types) 109 | type) 110 | (unify-one (first values-types) type)) 111 | ((list type (cons 'values values-types)) 112 | (unify-one type (first values-types))) 113 | ;; functions with &rest in lambda-list 114 | ;; FIXME: this is not good enough. &rest arguments can appear 115 | ;; in other places other than as first argument. 116 | ((list (list 'function (list '&rest rest-type-1) return-type-1) 117 | (list 'function (list '&rest rest-type-2) return-type-2)) 118 | (append (unify-one return-type-1 return-type-2) 119 | (unify-one rest-type-1 rest-type-2))) 120 | ((list (list 'function args-1 return-value-1) 121 | (list 'function (list '&rest rest-type) return-value-2)) 122 | (append (unify-one return-value-1 return-value-2) 123 | (apply #'append 124 | (mapcar (curry #'unify-one rest-type) args-1)))) 125 | ((list (list 'function (list '&rest rest-type) return-value-1) 126 | (list 'function args-2 return-value-2)) 127 | (append (unify-one return-value-1 return-value-2) 128 | (apply #'append 129 | (mapcar (curry #'unify-one rest-type) args-2)))) 130 | ;; functions 131 | ((list (list 'function args-1 return-value-1) 132 | (list 'function args-2 return-value-2)) 133 | ;; This is dependant on order: 134 | ;; (unify-one return-value-2 return-value-1) is different 135 | ;; from (unify-one return-value-1 return-value-2). 136 | ;; Not sure if that is correct or desired. 137 | (append 138 | ;;(unify-one return-value-1 return-value-2) 139 | (unify-one return-value-2 return-value-1) 140 | #+nil(apply #'append 141 | (mapcar (lambda (args) 142 | (apply #'unify-one args)) 143 | (mapcar #'list args-2 args-1 ))) 144 | (apply #'append 145 | (mapcar (lambda (args) 146 | (apply #'unify-one args)) 147 | (mapcar #'list args-1 args-2 ))) 148 | )) 149 | ;; or type 150 | ;; FIXME: this is not good enough 151 | ((list type (cons 'or types)) 152 | (if (= (length types) 1) 153 | (unify-one type (first types)) 154 | (handler-case 155 | (unify-one type (first types)) 156 | (type-unification-error () 157 | (unify-one type (list 'or (rest types))))))) 158 | ;; rest of types 159 | ((list type1 type2) 160 | (multiple-value-bind (subst unified?) 161 | (unify-types (list term1 term2)) 162 | (unless unified? 163 | ;; unify iff type1 and type2 can be coerced 164 | ;; (when (subtypep type1 type2) 165 | ;; (return-from unify-one (list (cons type2 type1)))) 166 | ;; (when (subtypep type2 type1) 167 | ;; (return-from unify-one (list (cons type1 type2)))) 168 | ;; (error 'type-unification-error 169 | ;; :format-control "Can't unify: ~s with: ~s" 170 | ;; :format-arguments (list type1 type2)) 171 | 172 | (unless (or (eql type1 t) 173 | (eql type2 t) 174 | ;;(subtypep type1 type2) 175 | (subtypep type2 type1) 176 | ) 177 | (error 'type-unification-error 178 | :format-control "Can't unify: ~s with: ~s" 179 | :format-arguments (list type1 type2)))) 180 | subst))))) 181 | (format *debug-unification* " => ~a ~%" unification) 182 | unification)) 183 | 184 | ;;(unify-one '(list-of integer) '(list-of string)) 185 | ;;(unify-one '(list-of integer) '(list-of number)) 186 | 187 | (declaim (ftype (function (cons t) t) subst-term)) 188 | (defun subst-term (assignment term) 189 | "Substitute ASSIGNMENT in TERM. 190 | ASSIGNMENT is CONS of VAR to a TERM." 191 | (when (null term) 192 | (return-from subst-term term)) 193 | (trivia:match (list assignment term) 194 | ((list (cons varname val) (var (%0 x))) 195 | (if (eql varname x) 196 | val 197 | term)) 198 | ((list assignment (or-type (%0 or-cases))) 199 | (or-type (mapcar (curry 'subst-term assignment) or-cases))) 200 | (_ 201 | (cond 202 | ((listp term) 203 | (cons (subst-term assignment (car term)) 204 | (mapcar (curry 'subst-term assignment) (cdr term)))) 205 | (t term))))) 206 | 207 | ;; A substituion is a list of assignments 208 | (defun apply-substitution (assignments term) 209 | (let ((new-term term)) 210 | (dolist (assignment assignments) 211 | (setq new-term (subst-term assignment new-term))) 212 | new-term)) 213 | 214 | (defun unify (constraints) 215 | "Unify CONSTRAINTS." 216 | (when constraints 217 | (let* ((substitution (unify (rest constraints))) 218 | (constraint (first constraints)) 219 | (sub2 220 | (unify-one (apply-substitution substitution (car constraint)) 221 | (apply-substitution substitution (cdr constraint))))) 222 | (append sub2 substitution)))) 223 | 224 | #| 225 | (unify `((,(var 'x 'x) . ,(var 'y 'y)))) => '((x . (var y))) 226 | (unify `((,(var 'x 'x) . integer))) => '((x . integer)) 227 | (unify '((integer . (var x)))) => '((x . integer)) 228 | (unify '(((var x) . (list-of integer)))) => '((x . (list-of integer))) 229 | (unify '((all (a) (list-of a)) . integer)) => '((a . integer)) 230 | (unify '(integer . (all (a) (list-of a)))) => '((a . integer)) 231 | 232 | (unify '(((var x) . integer) ((var x) . boolean))) => error 233 | (unify '(((var x) . integer) ((var y) . boolean) ((var x) . (var y)))) 234 | 235 | (unify `((integer . t))) ;; success 236 | (unify `((integer . nil))) ;; success 237 | (unify `((integer . fixnum))) ;; success 238 | (unify `((fixnum . integer))) ;; success 239 | (unify `((integer . string))) ;; fail 240 | 241 | The steps: 242 | (unify '((var x) . integer) ((var x) . boolean)) => 243 | (unify '(integer . boolean)) => error 244 | 245 | mapcar :: (all (a b) (function ((function (a) b) (list-of a)) (list-of b))) 246 | 247 | + :: (function (&rest number) number) 248 | 249 | (mapcar + (list 1 2 3)) 250 | 251 | inference of (mapcar + (list 1 2 3 x)): 252 | 253 | (unify '((all (a b) (function (a) b)) (function (&rest number) number)) 254 | '((all (a b) (list-of b)) (list-of number))) 255 | => 256 | (unify '((a . (&rest number)) (b . number)) 257 | '((b . number))) 258 | => '((a . number) (b . number)) 259 | 260 | ------------------ 261 | 262 | (unify '(integer . (list-of (var-type a)))) => 263 | 264 | |# 265 | 266 | 267 | #| 268 | 269 | Generation of type constraints for an expression e 270 | 271 | In a type environment, assign a unique type variable to each variable x ocurring in e 272 | Assign a unique type variable to each subexpression of e 273 | 274 | Constraints: 275 | 276 | Call the type variable assigned to x, u(x), and call the type variable assigned to occurrence of a subexpression e', v(e'). 277 | 278 | Now we take the following constraints: 279 | 280 | * u(x) = v(x) for each occurrence of a variable x. 281 | * v(e1) = v(e2) -> v((e1 e2)) for each occurrence of a subexpression (e1 e2). 282 | * v(fun x -> e) = v(x) -> v(e) for each occurrence of a subexpression fun x -> e. 283 | 284 | * For each occurrence of a variable x, u(x) = v(x) . 285 | * For each occurrence of function application (fn e), v(fn) = (function (v(e)) v(fn e)) 286 | * For each occurrence of a subexpression (lambda (x) e), v(lambda (x) e) = (function (v(x)) (v(e))). 287 | 288 | (generate '(+ 12 x)) 289 | 290 | Env: + -> g1, x -> g2, 12 -> g3, (+ 12 x) -> g4, (g1, .., gN) type variables. 291 | 292 | g2 = g2 293 | g2 = integer 294 | g3 = g3 295 | g4 = integer 296 | g1 = (function (g2 g3) g4) 297 | 298 | Unify: 299 | g1 = (function (integer g3) integer) 300 | 301 | |# 302 | 303 | (defstruct type-env 304 | (symbol-nr 0 :type integer) 305 | (vars nil :type list) 306 | (constraints nil :type list) 307 | (unified nil :type list) 308 | (declared-ftypes nil :type list) 309 | (declared-vartypes nil :type list) 310 | (debugp nil :type boolean)) 311 | 312 | (declaim (ftype (function (walked-form type-env) var))) 313 | (defun new-var (form env) 314 | "Create a new type variable for FORM in ENV." 315 | (let* ((varname (intern (format nil "VAR~a" (incf (type-env-symbol-nr env))))) 316 | (var (var varname 317 | (when (type-env-debugp env) 318 | form)))) 319 | (push (cons varname form) (type-env-vars env)) 320 | var)) 321 | 322 | (declaim (ftype (function (t t type-env) t) add-constraint)) 323 | (defun add-constraint (x y env) 324 | "Add constraint from type term X to type term Y, in ENV" 325 | (push (cons x y) (type-env-constraints env))) 326 | 327 | (declaim (ftype (function (walked-form type-env list) list) generate-type-constraints)) 328 | (defgeneric generate-type-constraints (form env locals) 329 | (:documentation "Generate type constraints for FORM in ENV under LOCALS.")) 330 | 331 | (defmethod generate-type-constraints ((form constant-form) env locals) 332 | (let ((var (new-var form env)) 333 | (type (if (functionp (value-of form)) 334 | (get-func-type (value-of form) env) 335 | (type-of (value-of form))))) 336 | (add-constraint var type env) 337 | var)) 338 | 339 | (defmethod generate-type-constraints ((form let-form) env locals) 340 | (let ((let-locals locals)) 341 | (dolist (binding (bindings-of form)) 342 | (let ((binding-value-var 343 | (generate-type-constraints (initial-value-of binding) env locals))) 344 | (let ((binding-var (new-var binding env))) 345 | (add-constraint binding-var binding-value-var env) 346 | (push (cons (name-of binding) binding-var) let-locals)))) 347 | ;; The type of the let is the type of the last expression in body, so return that 348 | (let ((body-var nil) 349 | (let-var (new-var form env))) 350 | (dolist (body-form (body-of form)) 351 | (setf body-var (generate-type-constraints body-form env let-locals))) 352 | (add-constraint let-var body-var env) 353 | let-var))) 354 | 355 | (defmethod generate-type-constraints ((form lexical-variable-reference-form) env locals) 356 | (let ((var (new-var form env)) 357 | (local-var (or (cdr (find (name-of form) locals :key #'car)) 358 | (error "Badly done")))) 359 | (add-constraint var local-var env) 360 | var)) 361 | 362 | (defmethod generate-type-constraints ((form the-form) env locals) 363 | (let ((var (new-var form env))) 364 | (add-constraint var (declared-type-of form) env) 365 | (add-constraint var (generate-type-constraints (value-of form) env locals) env) 366 | var)) 367 | 368 | (defmethod generate-type-constraints ((form setq-form) env locals) 369 | ;; Should constrain only if variable has a DECLARED type, not inferred.. 370 | (let ((var (new-var form env)) 371 | (local-var (or (cdr (find (name-of (variable-of form)) locals :key #'car)) 372 | (error "Badly done"))) 373 | (value-var (generate-type-constraints (value-of form) env locals))) 374 | (add-constraint var local-var env) 375 | (add-constraint var value-var env) 376 | var)) 377 | 378 | (defmethod generate-type-constraints ((form implicit-progn-mixin) env locals) 379 | (let ((var (new-var form env))) 380 | (dolist (expr (body-of form)) 381 | (setq var (generate-type-constraints expr env locals))) 382 | var)) 383 | 384 | (defmethod generate-type-constraints ((form go-tag-form) env locals) 385 | ;; what to do? 386 | (let ((var (new-var form env))) 387 | (add-constraint var 't env) 388 | var)) 389 | 390 | (defmethod generate-type-constraints ((form go-form) env locals) 391 | ;; what to do? 392 | (let ((var (new-var form env))) 393 | (add-constraint var 't env) 394 | var)) 395 | 396 | (defparameter *type-declarations* '()) 397 | 398 | (declaim (ftype (function ((or symbol function) type-env) t) get-func-type)) 399 | (defun get-func-type (func env) 400 | "Get the type of function with FNAME in ENV." 401 | (let ((fname (typecase func 402 | (symbol func) 403 | (function (compiler-info:function-name func))))) 404 | ;; First try to get from the read declarations 405 | (dolist (funtype *funtypes*) 406 | (when (eql fname (car funtype)) 407 | (return-from get-func-type (cdr funtype)))) 408 | (dolist (decl *type-declarations*) 409 | (destructuring-bind (declaration-type &rest declaration-body) decl 410 | (when (member (symbol-name declaration-type) '("FTYPE" "FTYPE*") 411 | :test #'string=) 412 | (when (eql (lastcar declaration-body) fname) 413 | (return-from get-func-type (car declaration-body)))))) 414 | ;; If none found, use compiler information 415 | (or (compiler-info:function-type fname) 416 | ;; Or a generic function type 417 | '(function (&rest t) t)))) 418 | 419 | ;; (get-func-type 'identity (make-type-env)) 420 | ;; (get-func-type 'concatenate (make-type-env)) 421 | ;; (get-func-type #'identity (make-type-env)) 422 | ;; (get-func-type #'+ (make-type-env)) 423 | 424 | (declaim (ftype (function (t type-env) t) instantiate-type)) 425 | (defun instantiate-type (type env) 426 | "Create an instance of TYPE in ENV. 427 | Type parameters are substituted by type variables." 428 | (trivia:match type 429 | ((list 'all type-args type) 430 | (let ((type-instance type)) 431 | (dolist (type-arg type-args) 432 | (let ((type-var (new-var type-arg env))) 433 | (setq type-instance (subst type-var type-arg type-instance)))) 434 | type-instance)) 435 | ((cons type-name args) 436 | (cons type-name (mapcar (rcurry #'instantiate-type env) args))) 437 | (_ type))) 438 | 439 | ;; (instantiate-type '(all (a) (list-of a)) (make-type-env)) 440 | ;; (instantiate-type '(all (a) (function (a) a)) (make-type-env)) 441 | ;; (instantiate-type 'integer (make-type-env)) 442 | ;; (instantiate-type '(function (integer) t) (make-type-env)) 443 | ;; (instantiate-type '(or (all (a) (function (a) boolean)) 444 | ;; (all (a b) (function (a b) b))) 445 | ;; (make-type-env)) 446 | 447 | (declaim (ftype (function (t) t) generalize-type)) 448 | (defun generalize-type (type) 449 | "Generalize TYPE." 450 | (let ((var-counter 64) 451 | (vars (list))) 452 | (labels ((var-for (varname) 453 | (or (cdr (assoc varname vars)) 454 | (let ((var (intern (princ-to-string (code-char (incf var-counter)))))) 455 | (push (cons varname var) vars) 456 | var))) 457 | (generalize-term (term) 458 | (trivia:match term 459 | ((var (%0 varname) (%1 varinfo)) 460 | (var-for varname)) 461 | ((cons x xs) 462 | (cons (generalize-term x) (mapcar #'generalize-term xs))) 463 | (_ term)))) 464 | (let ((term-body (generalize-term type))) 465 | (if vars 466 | `(all ,(nreverse (mapcar #'cdr vars)) ,term-body) 467 | type))))) 468 | 469 | ;; (generalize-type `(list-of ,(var 'a nil))) 470 | ;; (generalize-type `(function (,(var 'a nil) ,(var 'b nil)) ,(var 'b nil))) 471 | ;; (generalize-type `(function (,(var 'a nil) ,(var 'b nil)) ,(var 'a nil))) 472 | ;; (generalize-type `(function (,(var 'a nil) ,(var 'b nil)) ,(var 'z nil))) 473 | 474 | (declaim (ftype (function (t walked-form type-env list) t) 475 | generate-function-application-constraints)) 476 | (defun generate-function-application-constraints (func-type form env locals) 477 | "Generate type constraints for function application." 478 | (let ((arg-types (assign-types-from-function-type 479 | func-type 480 | (arguments-of form))) 481 | (arg-vars nil)) 482 | 483 | ;; Constraint the types of the arguments 484 | (loop for arg in (arguments-of form) 485 | for arg-type in arg-types 486 | do 487 | (let ((arg-var (new-var arg env)) 488 | (actual-arg (generate-type-constraints arg env locals))) 489 | (if (typep (cdr arg-type) 'var) 490 | (add-constraint arg-var (cdr arg-type) env) 491 | ;;(add-constraint arg-var (accepts-type (cdr arg-type)) env) 492 | (add-constraint arg-var (cdr arg-type) env)) 493 | (add-constraint arg-var actual-arg env) 494 | (push arg-var arg-vars))) 495 | 496 | ;; Constraint the type of the application 497 | (let* ((return-type (lastcar func-type)) 498 | (app-var (new-var form env)) 499 | ;;(func-var (new-var (operator-of form) env)) 500 | ) 501 | (cond 502 | ;; Treat MAKE-INSTANCE specially 503 | ((and (eql (operator-of form) 'make-instance) 504 | (typep (first (arguments-of form)) 'constant-form)) 505 | (add-constraint app-var (value-of (first (arguments-of form))) env)) 506 | ;; Otherwise, the type of the application is the function return type 507 | (t 508 | (add-constraint app-var return-type env) 509 | ;;(add-constraint func-var `(function ,arg-vars ,app-var) env) 510 | )) 511 | app-var))) 512 | 513 | (defmethod generate-type-constraints ((form application-form) env locals) 514 | (let ((func-type (instantiate-type (get-func-type (operator-of form) env) env))) 515 | (generate-function-application-constraints 516 | func-type form env locals))) 517 | 518 | (defmethod generate-type-constraints ((form free-function-object-form) env locals) 519 | (let ((var (new-var form env))) 520 | (add-constraint var (instantiate-type (get-func-type (name-of form) env) env) env) 521 | var)) 522 | 523 | (defmethod generate-type-constraints ((form walked-lexical-variable-reference-form) env locals) 524 | (alexandria:if-let (local (assoc (name-of form) locals)) 525 | (let ((var (new-var form env))) 526 | (add-constraint var (cdr local) env) 527 | var) 528 | (error "Shouldn't happen"))) 529 | 530 | (defmethod generate-type-constraints-for-declarations (declarations bindings-vars form env locals) 531 | (dolist (declaration declarations) 532 | (typecase declaration 533 | (type-declaration-form 534 | (let ((binding-var (or (cdr (assoc (name-of declaration) 535 | bindings-vars :key #'name-of)) 536 | (error "Binding not found: ~s" (name-of declaration))))) 537 | (add-constraint binding-var (declared-type-of declaration) env)))))) 538 | 539 | (defmethod generate-type-constraints ((form lambda-function-form) env locals) 540 | (let* ((var (new-var form env)) 541 | (arg-types (mapcar (rcurry #'new-var env) (bindings-of form))) 542 | (lambda-locals (append (mapcar (lambda (arg arg-type) 543 | (cons (name-of arg) 544 | arg-type)) 545 | (bindings-of form) 546 | arg-types))) 547 | (body-type nil)) 548 | (generate-type-constraints-for-declarations 549 | (declarations-of form) (mapcar #'cons (bindings-of form) arg-types) 550 | form env (append locals lambda-locals)) 551 | (dolist (body-form (body-of form)) 552 | (setq body-type (generate-type-constraints body-form env (append locals lambda-locals)))) 553 | (add-constraint var `(function ,arg-types ,body-type) env) 554 | var)) 555 | 556 | (defmethod generate-type-constraints ((form if-form) env locals) 557 | (let ((then-type (generate-type-constraints (then-of form) env locals)) 558 | (else-type (generate-type-constraints (else-of form) env locals)) 559 | (var (new-var form env))) 560 | (add-constraint var `(or ,then-type ,else-type) env) 561 | var)) 562 | 563 | (defun canonize-type (type) 564 | (trivia:match type 565 | ;; Clean the (values &optional) types 566 | ((list 'values type '&optional) 567 | type) 568 | ((cons type-name args) 569 | (cons type-name (mapcar #'canonize-type args))) 570 | ((or-type (%0 subtypes)) 571 | (dolist (subtype subtypes) 572 | ;; Take the subtype that is fully unified (doesn't have variables). 573 | (when (not (some-tree (rcurry #'typep 'var) 574 | subtype)) 575 | (return-from canonize-type subtype)))) 576 | (_ type))) 577 | 578 | (defun infer-form (form &optional env) 579 | "Infer the type of FORM." 580 | (let ((type-env (or env (make-type-env))) 581 | (walked-form (hu.dwim.walker:walk-form form))) 582 | (generate-type-constraints walked-form type-env nil) 583 | (setf (type-env-unified type-env) (unify (type-env-constraints type-env))) 584 | (let ((type-assignments nil)) 585 | (dolist (type-assignment (type-env-unified type-env)) 586 | (trivia:match type-assignment 587 | ((cons x type) 588 | (let ((expr (cdr (assoc x (type-env-vars type-env))))) 589 | (push (cons expr 590 | (arrows:->> type 591 | (apply-substitution (type-env-unified type-env)) 592 | (canonize-type) 593 | (generalize-type))) 594 | type-assignments))))) 595 | (values 596 | ;; type of the walked form 597 | (cdr (assoc walked-form type-assignments)) 598 | ;; type-assignments of all subexpressions 599 | type-assignments 600 | ;; type environment 601 | type-env)))) 602 | -------------------------------------------------------------------------------- /type-checkers/constraints/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types/const) 2 | 3 | (defun assign-types-from-function-type (function-type args) 4 | "Assign types to the ARGS being passed to the function." 5 | (assert (eql (first function-type) 'function)) 6 | (destructuring-bind (_ arg-types return-type) function-type 7 | (declare (ignore _ return-type)) 8 | (let ((lambda-section '&required) 9 | (assignments) 10 | (args-queue args)) 11 | (dolist (arg-type arg-types) 12 | (block nil 13 | (when (member arg-type '(&optional &key &rest &aux)) 14 | (setf lambda-section arg-type) 15 | (return)) 16 | (case lambda-section 17 | (&required 18 | (let ((arg (pop args-queue))) 19 | (when (null arg) 20 | (error "Not enough arguments")) 21 | (push (cons arg arg-type) assignments))) 22 | (&optional 23 | (let ((arg (pop args-queue))) 24 | (when (null arg) 25 | (return)) 26 | (push (cons arg arg-type) assignments))) 27 | (&key 28 | (if (eql arg-type '&allow-other-keys) 29 | (setq lambda-section '&allow-other-keys) 30 | (destructuring-bind (key type) arg-type 31 | (let ((arg-val (getf args-queue key))) 32 | (when arg-val 33 | (push (cons arg-val type) assignments))) 34 | (alexandria:remove-from-plistf args-queue key)))) 35 | (&allow-other-keys) 36 | (&rest 37 | ;; Consume all the passed args 38 | (dolist (arg args-queue) 39 | (push (cons arg arg-type) 40 | assignments)) 41 | (setf args-queue nil))))) 42 | (unless (null args-queue) 43 | (if (eql lambda-section '&key) 44 | (error "Invalid key arguments in: ~s" args-queue) 45 | (error "Too many arguments"))) 46 | (nreverse assignments)))) 47 | 48 | #| 49 | 50 | (assign-types-from-function-type '(function () t) '()) 51 | (assign-types-from-function-type '(function (number) t) '(x)) 52 | (assign-types-from-function-type '(function (string &optional number) t) 53 | '(x)) 54 | (assign-types-from-function-type '(function (string &optional number) t) 55 | '()) 56 | 57 | (assign-types-from-function-type '(function (string &optional number) t) 58 | '(x y)) 59 | 60 | (assign-types-from-function-type '(function (string &optional number) t) 61 | '(x y z)) 62 | 63 | (assign-types-from-function-type '(function (string &key (:y number)) t) 64 | '(x)) 65 | 66 | (assign-types-from-function-type '(function (string &key (:y number)) t) 67 | '(x :y y)) 68 | 69 | (assign-types-from-function-type '(function (string &key (:y number)) t) 70 | '(x :y y :z "lala")) 71 | 72 | (assign-types-from-function-type '(function (string &key (:y number)) t) 73 | '(x :y y :z "lala")) 74 | 75 | (assign-types-from-function-type '(function (&rest number) t) '(x y z)) 76 | 77 | |# 78 | 79 | ;; Works over a walked application-form 80 | (declaim (ftype (function (list walked-form) t) assign-types-from-function-type-2)) 81 | (defun assign-types-from-function-type-2 (function-type application-form) 82 | (declare (type list function-type) 83 | (type application-form application-form)) 84 | (assert (eql (first function-type) 'function)) 85 | (destructuring-bind (_ arg-types return-type) function-type 86 | (declare (ignore _ return-type)) 87 | (let ((lambda-section '&required) 88 | (assignments (list)) 89 | (args-queue (arguments-of application-form)) 90 | (keys-in-plist-format nil)) 91 | (dolist (arg-type arg-types) 92 | (block nil 93 | (when (member arg-type '(&optional &key &rest &aux)) 94 | (setf lambda-section arg-type) 95 | (return)) 96 | (case lambda-section 97 | (&required 98 | (let ((arg (pop args-queue))) 99 | (when (null arg) 100 | (error "Not enough arguments")) 101 | (push (cons arg arg-type) assignments))) 102 | (&optional 103 | (let ((arg (pop args-queue))) 104 | (when (null arg) 105 | (return)) 106 | (push (cons arg arg-type) assignments))) 107 | (&key 108 | (if (eql arg-type '&allow-other-keys) 109 | (setq lambda-section '&allow-other-keys) 110 | (progn 111 | ;; Convert the list of walked-forms to a plist 112 | (when (not keys-in-plist-format) 113 | (setf args-queue (loop for key in args-queue by #'cddr 114 | for value in (rest args-queue) by #'cddr 115 | collect (value-of key) 116 | collect value)) 117 | (setf keys-in-plist-format t)) 118 | (destructuring-bind (key type) arg-type 119 | (let ((arg-val (getf args-queue key))) 120 | (when arg-val 121 | (push (cons arg-val type) assignments))) 122 | (alexandria:remove-from-plistf args-queue key))))) 123 | (&allow-other-keys) 124 | (&rest 125 | ;; Consume all the passed args 126 | (dolist (arg args-queue) 127 | (push (cons arg arg-type) assignments)) 128 | (setf args-queue nil))))) 129 | (unless (null args-queue) 130 | (if (eql lambda-section '&key) 131 | (error "Invalid key arguments in: ~s" args-queue) 132 | (error "Too many arguments"))) 133 | (nreverse assignments)))) 134 | 135 | #| 136 | 137 | (assign-types-from-function-type-2 '(function () t) (walk-form '(foo))) 138 | (assign-types-from-function-type-2 '(function (number) t) (walk-form '(foo x))) 139 | (assign-types-from-function-type-2 '(function (string &optional number) t) 140 | (walk-form '(foo x))) 141 | (assign-types-from-function-type-2 '(function (string &optional number) t) 142 | (walk-form '(foo))) 143 | 144 | (assign-types-from-function-type-2 '(function (string &optional number) t) 145 | (walk-form '(foo x y))) 146 | 147 | (assign-types-from-function-type-2 '(function (string &optional number) t) 148 | (walk-form '(foo x y z))) 149 | 150 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 151 | (walk-form '(foo x))) 152 | 153 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 154 | (walk-form '(foo x :y y))) 155 | 156 | (assign-types-from-function-type-2 '(function (string &key (:y number)) t) 157 | (walk-form '(foo x :y y :z "lala"))) 158 | 159 | (assign-types-from-function-type '(function (string &key (:y number)) t) 160 | '(x :y y :z "lala")) 161 | 162 | (assign-types-from-function-type-2 '(function (&rest number) t) 163 | (walk-form '(foo x y z))) 164 | 165 | |# 166 | 167 | (defun some-tree (predicate tree) 168 | (cond 169 | ((atom tree) (funcall predicate tree)) 170 | ((listp tree) 171 | (or (funcall predicate tree) 172 | (some (curry #'some-tree predicate) tree))))) 173 | 174 | ;; (some-tree (lambda (x) 175 | ;; (and (listp x) 176 | ;; (eql (car x) 'var))) 177 | ;; '(or (var x))) 178 | 179 | ;; (some-tree (lambda (x) 180 | ;; (and (listp x) 181 | ;; (eql (car x) 'var))) 182 | ;; '(or x z)) 183 | 184 | ;; (defun tree-find-if (predicate tree) 185 | ;; (cond 186 | ;; ((atom tree) 187 | ;; (when (funcall predicate tree) 188 | ;; tree)) 189 | ;; ((listp tree) 190 | ;; (when (funcall predicate tree) 191 | ;; (return-from tree-find-if tree)) 192 | ;; (dolist (x tree) 193 | ;; (when (tree-find-if predicate x) 194 | ;; (return-from tree-find-if x)))) 195 | ;; (t nil))) 196 | 197 | ;; (tree-find-if (lambda (x) 198 | ;; (and (listp x) 199 | ;; (eql (car x) 'var))) 200 | ;; '(or (var x))) 201 | 202 | ;; (tree-find-if (lambda (x) 203 | ;; (and (listp x) 204 | ;; (eql (car x) 'var))) 205 | ;; '(or x z)) 206 | 207 | (defun type-equalp (t1 t2) 208 | (and (subtypep t1 t2) 209 | (subtypep t2 t1))) 210 | 211 | (defun type-coerceablep (t1 t2) 212 | (or (subtypep t1 t2) 213 | (subtypep t2 t1))) 214 | 215 | (defun tree-find (what tree) 216 | (cond 217 | ((eql what tree) 218 | t) 219 | ((atom tree) 220 | nil) 221 | ((consp tree) 222 | (or (tree-find what (car tree)) 223 | (tree-find what (cdr tree)))) 224 | (t nil))) 225 | 226 | (tree-find 'a '(b (a))) 227 | 228 | (defun tree-find-if (predicate tree) 229 | (cond 230 | ((atom tree) 231 | (funcall predicate tree)) 232 | ((consp tree) 233 | (or (tree-find-if predicate (car tree)) 234 | (tree-find-if predicate (cdr tree)))))) 235 | 236 | -------------------------------------------------------------------------------- /type-checkers/rel/README.md: -------------------------------------------------------------------------------- 1 | ## Relational TypeChecker 2 | 3 | NOT IMPLEMENTED 4 | 5 | ### Implementation idea 6 | 7 | - Encode the types as Minikanren expressions. 8 | - Implement a supertypeo relationship, probably using the list of supertypes for a type: https://stackoverflow.com/questions/43565851/in-common-lisp-what-is-a-function-that-returns-the-most-specific-supertype-of-t 9 | supertypeo x y = y member of list-of-supertypes(x) 10 | - Parametric type vars are encoded as logic var. 11 | - Encode the any/dyn/unknown type encoded as logic var? 12 | - How to report errors? 13 | -------------------------------------------------------------------------------- /type-checkers/rel/type-inference.scm: -------------------------------------------------------------------------------- 1 | ; Hindley-Milner type inference and type population _relation_ 2 | ; 3 | ; This is a _pure_ relation that relates a term and its type. It can 4 | ; be used for type inference (determining the type for a term), type 5 | ; checking (making sure that a term is of the given type), and term 6 | ; reconstruction (constructing a term that has the desired type). We 7 | ; may also specify a part of a term and a part of a type, and ask the 8 | ; system to fill in the rest. In the latter applications, this code 9 | ; acts as a theorem prover in intuitionistic logic. 10 | ; 11 | ; When generating a term for a type, we may ask for terms in normal form 12 | ; only. We fully support polymorphic types and let-polymorphism. 13 | ; 14 | ; The end of the file shows the applications of the type reconstruction 15 | ; to deriving CPS terms for call/cc, shift, and reset from their types. 16 | ; 17 | ; This code is a re-write in mini-Kanren of the type checker in the full 18 | ; Kanren: ../examples/type-inference.scm (version 4.50 2005/02/12) 19 | ; We use only the second approach from that file. 20 | ; 21 | ; The term language is Scheme: integers, booleans, and pairs (aka products) 22 | ; are supported, along with a sum data type: 23 | ; constructors are (inl X), (inr X), and the deconstructor is 24 | ; (either (var Exp) on-left on-right) 25 | ; 26 | ; The internal term language is similar, with the explicit tags for 27 | ; integer and boolean literals. 28 | ; The type language is infix, with constants int, bool 29 | ; and _infix_ constructors ->, *, + 30 | ; The constructor -> is _right_ associative. 31 | ; 32 | 33 | ; Future plans: make sure that in the generation phase, all given 34 | ; variables are used (or used only once, etc). So, we can generate 35 | ; _or_ typecheck terms using uniqueness, linearity, etc. constraints. 36 | ; Regarding linearity: the `if' form has to be handled carefully, 37 | ; as its two branches are `parallel'. 38 | ; Add call/cc or abort as a primitive, and try to generate some formulas 39 | ; from classical logic. 40 | 41 | ; $Id: type-inference.scm,v 1.8 2006/01/10 09:44:48 oleg Exp $ 42 | 43 | 44 | (load "book-si.scm") ; Our complete evaluator 45 | (define unify unify-check) ; If we don't want recursive types 46 | 47 | ; The Unit testing framework 48 | (define-syntax test-check 49 | (syntax-rules () 50 | ((_ title tested-expression expected-result) 51 | (test-check title tested-expression expected-result #t)) 52 | ((_ title tested-expression expected-result show-flag) 53 | (begin 54 | (cout title "...") 55 | (let* ((expected expected-result) 56 | (produced tested-expression)) 57 | (if (equal? expected produced) 58 | (cout " works!" nl) 59 | (error 'test-check 60 | "Failed ~s: ~a~%Expected: ~a~%Computed: ~a~%" 61 | title 'tested-expression expected produced))))))) 62 | 63 | ; Unlike products -- car, cdr, cons -- sums are not standard in Scheme. 64 | ; The following is their simple implementation 65 | (define (inl x) (vector #f x)) 66 | (define (inr x) (vector #t x)) 67 | (define-syntax either 68 | (syntax-rules () 69 | ((either (v exp) onl onr) 70 | (let* ((x exp) 71 | (v (vector-ref x 1))) 72 | (if (vector-ref x 0) onr onl))))) 73 | 74 | 75 | ; We use a subset of Scheme itself as the source language 76 | ; The following two functions translate between the source language 77 | ; and the internal term language. 78 | ; NB! In the term language, all bound variables must be unique. So 79 | ; this function should also do alpha-renaming. 80 | ; The function 'parse' is somewhat similar to the syntax-rule 81 | ; processor in that both produce AST from the surface language -- and both 82 | ; annotate identifiers so that the names of all bound identifiers are unique. 83 | 84 | (define parse 85 | (lambda (term) (parse-env term '()))) 86 | 87 | (define (parse-env e env) 88 | (define (fmap e) (cons (car e) (map (lambda (t) (parse-env t env)) (cdr e)))) 89 | ; extend the env and support renaming. We rename the identifier 90 | ; only in the case of a conflict. 91 | ; the algorithm below is very dumb (but short) 92 | (define (env-ext v env) 93 | (if (not (assq v env)) (cons (cons v v) env) ; identity mapping 94 | (let loop ((cnt 1)) 95 | (let ((new-v 96 | (string->symbol 97 | (string-append (symbol->string v) (number->string cnt))))) 98 | (if (assq new-v env) (loop (+ 1 cnt)) 99 | (cons (cons v new-v) env)))))) 100 | (cond 101 | ((symbol? e) `(var ,(cdr (assq e env)))); support alpha-renaming 102 | ((number? e) `(intc ,e)) 103 | ((boolean? e) `(boolc ,e)) 104 | (else 105 | (case (car e) 106 | ((zero? sub1 + if cons car cdr inl inr fix) 107 | (fmap e)) 108 | ((lambda) 109 | (let* ((old-v (caadr e)) 110 | (new-env (env-ext old-v env)) 111 | (new-v (cdr (assq old-v new-env)))) 112 | `(lambda (,new-v) ,(parse-env (caddr e) new-env)))) 113 | ((let) 114 | (let* ((old-v (caar (cadr e))) 115 | (new-env (env-ext old-v env)) 116 | (new-v (cdr (assq old-v new-env)))) 117 | `(let ((,new-v ,(parse-env (cadar (cadr e)) env))) 118 | ,(parse-env (caddr e) new-env)))) 119 | ((either) 120 | (let* ((old-v (car (cadr e))) 121 | (new-env (env-ext old-v env)) 122 | (new-v (cdr (assq old-v new-env)))) 123 | `(either (,new-v ,(parse-env (cadr (cadr e)) env)) 124 | ,(parse-env (caddr e) new-env) 125 | ,(parse-env (cadddr e) new-env)))) 126 | (else (fmap (cons 'app e))))))) 127 | 128 | 129 | (define (unparse e) 130 | (define (fmap e) (cons (car e) (map unparse (cdr e)))) 131 | (case (car e) 132 | ((var) (cadr e)) 133 | ((intc) (cadr e)) 134 | ((boolc) (cadr e)) 135 | ((zero? sub1 + if cons car cdr inl inr fix) (fmap e)) 136 | ((lambda) `(lambda (,(car (cadr e))) ,(unparse (caddr e)))) 137 | ((let) 138 | `(let ((,(car (car (cadr e))) 139 | ,(unparse (cadr (car (cadr e)))))) 140 | ,(unparse (caddr e)))) 141 | ((either) 142 | `(either (,(car (cadr e)) 143 | ,(unparse (cadr (cadr e)))) 144 | ,(unparse (caddr e)) ,(unparse (cadddr e)))) 145 | ((app) (cdr (fmap e))))) 146 | 147 | 148 | ; We define a first-class (and recursive) relation !- 149 | ; so that (!- `(var ,v) t) holds iff the source term variable v has a type 150 | ; t. 151 | ; This variant is close to the `natural deduction' scheme. 152 | ; It also has an OO flavor: we need open recursion. 153 | 154 | ; The following are the separate components of which the relation 155 | ; !- will be built. All these components nevertheless receive the full 156 | ; !- as the argument. Actually, they will receive the 'self'-like 157 | ; argument. We need to explicitly find the fixpoint. 158 | 159 | ; Integer and boolean constants 160 | (define int-rel 161 | (lambda (s!-) 162 | (lambda (e t) 163 | (fresh (x) 164 | (== e `(intc ,x)) 165 | (== t 'int))))) 166 | 167 | (define bool-rel 168 | (lambda (s!-) 169 | (lambda (e t) 170 | (fresh (x) 171 | (== e `(boolc ,x)) 172 | (== t 'bool))))) 173 | 174 | 175 | ; types of primitive operations 176 | 177 | ; (zero? x) 178 | 179 | (define zero?-rel 180 | (lambda (s!-) 181 | (let ((!- (s!- s!-))) 182 | (lambda (e t) 183 | (fresh (x) 184 | (== e `(zero? ,x)) ; the term 185 | (== t 'bool) ; the type 186 | (!- x 'int)))))) ; provided that x is int 187 | 188 | (define sub1-rel 189 | (lambda (s!-) 190 | (let ((!- (s!- s!-))) 191 | (lambda (e t) 192 | (fresh (x) 193 | (== e `(sub1 ,x)) ; the term 194 | (== t 'int) ; the type 195 | (!- x 'int)))))) ; provided that x is int 196 | 197 | (define +-rel 198 | (lambda (s!-) 199 | (let ((!- (s!- s!-))) 200 | (lambda (e t) 201 | (fresh (x y) 202 | (== e `(+ ,x ,y)) ; the term 203 | (== t 'int) ; the type 204 | (!- x 'int) (!- y 'int)))))) ; provided that x,y are int 205 | 206 | ; products 207 | (define cons-rel 208 | (lambda (s!-) 209 | (let ((!- (s!- s!-))) 210 | (lambda (e t) 211 | (fresh (x y tx ty) 212 | (== e `(cons ,x ,y)) ; the term 213 | (== t `(,tx * ,ty)) ; the type 214 | (!- x tx) (!- y ty)))))) ; provided that x,y are typeable 215 | 216 | (define car-rel 217 | (lambda (s!-) 218 | (let ((!- (s!- s!-))) 219 | (lambda (e t) 220 | (fresh (x t2) 221 | (== e `(car ,x)) ; the term 222 | (!- x `(,t * ,t2))))))) ; provided that x is a product type 223 | 224 | (define cdr-rel 225 | (lambda (s!-) 226 | (let ((!- (s!- s!-))) 227 | (lambda (e t) 228 | (fresh (x t2) 229 | (== e `(cdr ,x)) ; the term 230 | (!- x `(,t2 * ,t))))))) ; provided that x is a product type 231 | ; sums 232 | (define inl-rel 233 | (lambda (s!-) 234 | (let ((!- (s!- s!-))) 235 | (lambda (e t) 236 | (fresh (x tl tr) 237 | (== e `(inl ,x)) ; the term 238 | (== t `(,tl + ,tr)) ; the type 239 | (!- x tl)))))) ; provided that x is typeable 240 | 241 | (define inr-rel 242 | (lambda (s!-) 243 | (let ((!- (s!- s!-))) 244 | (lambda (e t) 245 | (fresh (x tl tr) 246 | (== e `(inr ,x)) ; the term 247 | (== t `(,tl + ,tr)) ; the type 248 | (!- x tr)))))) ; provided that x is typeable 249 | 250 | 251 | ; conditionals 252 | 253 | (define if-rel 254 | (lambda (s!-) 255 | (let ((!- (s!- s!-))) 256 | (lambda (e t) 257 | (fresh (test conseq alt) 258 | (== e `(if ,test ,conseq ,alt)) ; the term 259 | (!- test 'bool) ; provided that test is bool 260 | (!- conseq t) 261 | (!- alt t)))))) ; and conseq, alt are of the same type 262 | 263 | 264 | ; Abstraction, application, fixpoint, and other binding forms 265 | 266 | ; Here we extend !- with an additional assumption that v has the type 267 | ; type-v. This extension corresponds to a non-generic, regular type. 268 | (define lambda-rel 269 | (lambda (s!-) 270 | (lambda (e t) 271 | (fresh (v tb body type-v) 272 | (== e `(lambda (,v) ,body)) 273 | (== t `(,type-v -> . ,tb)) 274 | (let* ((snew-!- 275 | (lambda (self) 276 | (lambda (e t) 277 | (conde ; lexically-scoped relation 278 | ((== e `(var ,v)) (== t type-v)) 279 | (else ((s!- self) e t)))))) 280 | (!- (snew-!- snew-!-))) 281 | (!- body tb)))))) ; check body in so extended env 282 | 283 | ; This is also a binding form 284 | (define either-rel 285 | (lambda (s!-) 286 | (let ((!- (s!- s!-))) 287 | (lambda (e t) 288 | (fresh (v x onl onr tl tr) 289 | (== e `(either (,v ,x) ,onl ,onr)) ; the term 290 | (!- x `(,tl + ,tr)) ; the sum type 291 | ; if onl is evaluated, v has the type tl 292 | ; this is similar to GADT! 293 | (let* ((snew-!- 294 | (lambda (self) 295 | (lambda (e t) 296 | (conde ; lexically-scoped relation 297 | ((== e `(var ,v)) (== t tl)) 298 | (else ((s!- self) e t)))))) 299 | (!- (snew-!- snew-!-))) 300 | (!- onl t)) 301 | ; if onr is evaluated, v has the type tr 302 | (let* ((snew-!- 303 | (lambda (self) 304 | (lambda (e t) 305 | (conde ; lexically-scoped relation 306 | ((== e `(var ,v)) (== t tr)) 307 | (else ((s!- self) e t)))))) 308 | (!- (snew-!- snew-!-))) 309 | (!- onr t)) 310 | ))))) 311 | 312 | (define app-rel 313 | (lambda (s!-) 314 | (let ((!- (s!- s!-))) 315 | (lambda (e t) 316 | (fresh (t-rand rand rator) 317 | (== e `(app ,rator ,rand)) 318 | (!- rator `(,t-rand -> . ,t)) 319 | (!- rand t-rand)))))) 320 | 321 | (define fix-rel 322 | (lambda (s!-) 323 | (let ((!- (s!- s!-))) 324 | (lambda (e t) 325 | (fresh (rand) 326 | (== e `(fix ,rand)) 327 | (!- rand `(,t -> . ,t))))))) 328 | 329 | ; Let with let-polymorphism 330 | ; The reason to test `(!- g rand some-type)' at the very beginning is 331 | ; to make sure that `rand' itself is well-typed. As Ken pointed out, 332 | ; we must outlaw expressions such as (let ((x (z z))) y) where 'x' 333 | ; does not occur in the body. The variable 'x' still must have some 334 | ; type. 335 | 336 | (define polylet-rel 337 | (lambda (s!-) 338 | (let ((!- (s!- s!-))) 339 | (lambda (e t) 340 | (fresh (v rand body) 341 | (== e `(let ((,v ,rand)) ,body)) 342 | (fresh (some-type) (!- rand some-type)) 343 | (let* ((snew-!- 344 | (lambda (self) 345 | (lambda (e t) 346 | (conde 347 | ((== e `(var ,v)) (!- rand t)) 348 | (else ((s!- self) e t)))))) 349 | (!- (snew-!- snew-!-))) 350 | (!- body t))))))) 351 | 352 | ; Now we build the recursive !- relation, as a fixpoint 353 | 354 | (define s!- 355 | (lambda (self) 356 | (lambda (e t) 357 | (conde 358 | (((int-rel self) e t)) 359 | (((bool-rel self) e t)) 360 | (((zero?-rel self) e t)) 361 | (((sub1-rel self) e t)) 362 | (((+-rel self) e t)) 363 | (((cons-rel self) e t)) 364 | (((car-rel self) e t)) 365 | (((cdr-rel self) e t)) 366 | (((inl-rel self) e t)) 367 | (((inr-rel self) e t)) 368 | (((either-rel self) e t)) 369 | (((if-rel self) e t)) 370 | (((lambda-rel self) e t)) 371 | (((app-rel self) e t)) 372 | (((fix-rel self) e t)) 373 | (((polylet-rel self) e t)) 374 | )))) 375 | 376 | (define !- (s!- s!-)) 377 | 378 | 379 | ;------------------------------------------------------------------------ 380 | ; tests 381 | 382 | 383 | (test-check 'test-!-1 384 | (run* (q) (!- '(intc 17) 'int)) 385 | '(_.0)) 386 | 387 | (test-check 'test-!-2 388 | (run* (q) (!- '(intc 17) q)) 389 | '(int)) 390 | 391 | (test-check 'test-primitives 392 | (run* (q) (!- '(zero? (intc 24)) q)) 393 | '(bool)) 394 | 395 | (test-check 'test-sub1 396 | (run* (q) (!- '(zero? (sub1 (intc 24))) q)) 397 | '(bool)) 398 | 399 | (test-check 'test-+ 400 | (run* (q) (!- '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) q)) 401 | '(bool)) 402 | 403 | (test-check 'test-if 404 | (run* (q) (!- '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) q)) 405 | '(bool)) 406 | 407 | (test-check 'test-if-2 408 | (run* (q) 409 | (!- '(if (if (zero? (intc 1)) (boolc #t) (boolc #f)) 410 | (intc 0) 411 | (+ (intc 1) (intc 2))) 412 | q)) 413 | '(int)) 414 | 415 | (test-check 'test-parse 416 | (parse '(lambda (x) (lambda (x) x))) 417 | '(lambda (x) (lambda (x1) (var x1)))) 418 | 419 | 420 | (test-check 'variables-4a 421 | (run* (q) (!- '(lambda (x) (+ (var x) (intc 5))) q)) 422 | '((int -> . int))) 423 | 424 | 425 | (test-check 'variables-4c 426 | (run* (q) (!- '(lambda (a) (lambda (x) (+ (var x) (var a)))) q)) 427 | '((int -> int -> . int))) 428 | 429 | 430 | (test-check 'variables-product 431 | (run* (q) (!- (parse '(lambda (a) (cdr (car (cons a 1))))) q)) 432 | '(((_.0 * _.1) -> . _.1))) 433 | 434 | (test-check 'variables-sum 435 | (run* (q) (!- 436 | (parse 437 | '(lambda (x) (either (v x) (inl (car v)) (inr (cdr v))))) 438 | q)) 439 | '((((_.0 * _.1) + (_.2 * _.3)) -> . (_.0 + _.3)))) 440 | 441 | (test-check 'everything-but-polymorphic-let-1 442 | (run* (q) 443 | (!- (parse 444 | '(lambda (f) 445 | (lambda (x) 446 | ((f x) x)))) 447 | q)) 448 | '(((_.0 -> _.0 -> . _.1) -> _.0 -> . _.1))) 449 | 450 | 451 | (test-check 'everything-but-polymorphic-let-2 452 | (run* (q) 453 | (!- (parse 454 | '((fix (lambda (sum) 455 | (lambda (n) 456 | (+ n (sum (sub1 n)))))) 457 | 10)) 458 | q)) 459 | '(int)) 460 | 461 | ; The following should not typecheck because lambda-binding is not polymorphic 462 | (test-check 'everything-but-polymorphic-let-3 463 | (run* (q) 464 | (!- (parse '((lambda (f) 465 | (if (f (zero? 5)) 466 | (+ (f 4) 8) 467 | (+ (f 3) 7))) 468 | (lambda (x) x))) 469 | q)) 470 | '()) 471 | 472 | ; But if we use let, with its let-polymorphis, it works. 473 | (test-check 'polymorphic-let-1 474 | (run* (q) 475 | (!- (parse 476 | '(let ((f (lambda (x) x))) 477 | (if (f (zero? 5)) 478 | (+ (f 4) 8) 479 | (+ (f 3) 7)))) 480 | q)) 481 | '(int)) 482 | 483 | 484 | (test-check 'with-robust-syntax 485 | (run* (q) 486 | (!- '(app 487 | (fix 488 | (lambda (sum) 489 | (lambda (n) 490 | (if (if (zero? (var n)) (boolc #t) (boolc #f)) 491 | (intc 0) 492 | (+ (var n) (app (var sum) (sub1 (var n)))))))) 493 | (intc 10)) 494 | q)) 495 | '(int)) 496 | 497 | (test-check "test19" 498 | (run* (q) 499 | (!- (parse '((fix (lambda (sum) 500 | (lambda (n) 501 | (+ n (sum (sub1 n)))))) 502 | 10)) 503 | q)) 504 | '(int)) 505 | 506 | 507 | ; Generating a term for a type 508 | (test-check 'type-habitation-1 509 | (run 10 (q) (!- q 'int)) 510 | '((intc _.0) 511 | (sub1 (intc _.0)) 512 | (+ (intc _.0) (intc _.1)) 513 | (sub1 (sub1 (intc _.0))) 514 | (sub1 (+ (intc _.0) (intc _.1))) 515 | (+ (sub1 (intc _.0)) (intc _.1)) 516 | (sub1 (sub1 (sub1 (intc _.0)))) 517 | (car (cons (intc _.0) (intc _.1))) 518 | (sub1 (sub1 (+ (intc _.0) (intc _.1)))) 519 | (+ (intc _.0) (sub1 (intc _.1)))) 520 | ) 521 | 522 | (test-check 'type-habitation-2 523 | (run 5 (q) (!- q '(int -> . int))) 524 | '((lambda (_.0) (var _.0)) 525 | (car (cons (lambda (_.0) (var _.0)) (intc _.1))) 526 | (car (cons (lambda (_.0) (var _.0)) (boolc _.1))) 527 | (cdr (cons (intc _.0) (lambda (_.1) (var _.1)))) 528 | (car (cons (lambda (_.0) (var _.0)) (zero? (intc _.1))))) 529 | ) 530 | 531 | 532 | ; Note the constants 'a rather than logical variables a: 533 | ; 'a is an eigne-value. We want to have the polymorphic type 534 | (test-check 'type-habitation-3 535 | (run 10 (q) (!- q `((a -> . a) -> . (a -> . a)))) 536 | '((lambda (_.0) (var _.0)) 537 | (car (cons (lambda (_.0) (var _.0)) (intc _.1))) 538 | (car (cons (lambda (_.0) (var _.0)) (boolc _.1))) 539 | (cdr (cons (intc _.0) (lambda (_.1) (var _.1)))) 540 | (car (cons (lambda (_.0) (var _.0)) (zero? (intc _.1)))) 541 | (car (cons (lambda (_.0) (var _.0)) (sub1 (intc _.1)))) 542 | (either 543 | (_.0 (inl (intc _.1))) 544 | (lambda (_.2) (var _.2)) 545 | (var _.0)) 546 | (car (cons (car (cons (lambda (_.0) (var _.0)) (intc _.1))) 547 | (intc _.2))) 548 | (car (cons (lambda (_.0) (var _.0)) 549 | (+ (intc _.1) (intc _.2)))) 550 | (car (car (cons (cons (lambda (_.0) (var _.0)) (intc _.1)) 551 | (intc _.2))))) 552 | ) 553 | 554 | (test-check 'type-habitation-4 555 | (run 10 (q) 556 | (fresh (_) (== q `(lambda . ,_)) (!- q `((a -> . a) -> . (a -> . a))))) 557 | '((lambda (_.0) (var _.0)) 558 | (lambda (_.0) (car (cons (var _.0) (var _.0)))) 559 | (lambda (_.0) (cdr (cons (var _.0) (var _.0)))) 560 | (lambda (_.0) (car (cons (var _.0) (intc _.1)))) 561 | (lambda (_.0) (cdr (cons (intc _.1) (var _.0)))) 562 | (lambda (_.0) (lambda (_.1) (var _.1))) 563 | (lambda (_.0) 564 | (car (car (cons (cons (var _.0) (var _.0)) (var _.0))))) 565 | (lambda (_.0) (car (cons (var _.0) (boolc _.1)))) 566 | (lambda (_.0) (if (boolc _.1) (var _.0) (var _.0))) 567 | (lambda (_.0) (cdr (cons (boolc _.1) (var _.0))))) 568 | ) 569 | 570 | ; If we wish to find only combinators, we can tell the system what 571 | ; kind of terms to use 572 | 573 | (define-syntax make-! 574 | (syntax-rules () 575 | ((_ rel ...) 576 | ((lambda (x) (x x)) 577 | (lambda (self) 578 | (lambda (e t) 579 | (conde 580 | (((rel self) e t)) ... 581 | ))))))) 582 | 583 | (define c!- (make-! lambda-rel app-rel)) 584 | 585 | 586 | (time 587 | (map unparse 588 | (run 10 (q) 589 | (fresh (_) (== q `(lambda . ,_)) 590 | (c!- q `((a -> . a) -> . (a -> . a))))))) 591 | 592 | (cout nl "Some examples from Djinn: inferring morphisms of the continuation 593 | monad" nl) 594 | ; Some examples from Djinn: deriving the type of return and call/cc 595 | ; in the continuation monad: 596 | 597 | ; Djinn> returnC ? a -> C a 598 | ; returnC :: a -> C a 599 | ; returnC x1 x2 = x2 x1 600 | 601 | (define (cont a) `((,a -> . r) -> . r)) 602 | (display (map unparse (run 1 (q) (c!- q `(a -> . ,(cont 'a)))))) 603 | (newline) 604 | 605 | ; Djinn> bindC ? C a -> (a -> C b) -> C b 606 | ; bindC :: C a -> (a -> C b) -> C b 607 | ; bindC x1 x2 x3 = x1 (\ c15 -> x2 c15 (\ c17 -> x3 c17)) 608 | 609 | ; Deriving the expression for call/cc and bind is really difficult. So, 610 | ; we restrict the app-rel to avoid the redexes. We don't want to generate 611 | ; terms with redexes anyway... 612 | ; The above prevents call-by-name redexes. We may wish to exclude only CBV 613 | ; redexes (lambdas and variables in the operand position). It is interesting 614 | ; how it changes the result... 615 | (define appn-rel 616 | (lambda (s!-) 617 | (let ((!- (s!- s!-))) 618 | (lambda (e t) 619 | (fresh (t-rand rand rator) 620 | (== e `(app ,rator ,rand)) 621 | (fresh (_) (conde ((== rator `(var ,_))) 622 | (else (== rator `(app . ,_))))) 623 | (!- rator `(,t-rand -> . ,t)) 624 | (!- rand t-rand)))))) 625 | (define c!- (make-! lambda-rel appn-rel)) 626 | 627 | (cout nl "bind" nl) 628 | (cout 629 | (time 630 | (map unparse 631 | (run 1 (q) 632 | (fresh (x1 x2 _) (== q `(lambda (,x1) (lambda (,x2) . ,_))) 633 | (c!- q `(,(cont 'a) -> . ((a -> . ,(cont 'b)) -> . ,(cont 'b)))))))) 634 | nl) 635 | 636 | ; Djinn> type C a = (a -> r) -> r 637 | ; Djinn> callCC ? ((a -> C b) -> C a) -> C a 638 | ; callCC x1 x2 = x1 (\ c15 _ -> x2 c15) (\ c11 -> x2 c11) 639 | 640 | (cout nl "call/cc" nl) 641 | (cout 642 | (time 643 | (map unparse 644 | (run 1 (q) 645 | (fresh (x1 x2 _) (== q `(lambda (,x1) (lambda (,x2) . ,_))) 646 | (c!- q `(((a -> . ,(cont 'b)) -> . ,(cont 'a)) -> . ,(cont 'a))))))) 647 | nl) 648 | 649 | 650 | (cout nl "Inferring the expressions for shift and reset" nl) 651 | 652 | (define (cont a r) `((,a -> . ,r) -> . ,r)) 653 | 654 | (cout nl "reset" nl) 655 | (cout 656 | (time 657 | (map unparse 658 | (run 1 (q) 659 | (fresh (x1 x2 _) (== q `(lambda (,x1) (lambda (,x2) . ,_))) 660 | (c!- q `(,(cont 'a 'a) -> . ,(cont 'a 'r))))))) 661 | nl) 662 | 663 | (cout nl "shift" nl) 664 | (cout 665 | (time 666 | (map unparse 667 | (run 1 (q) 668 | (fresh (x1 x2 _) (== q `(lambda (,x1) (lambda (,x2) . ,_))) 669 | (c!- q `(((a -> . ,(cont 'b 'r)) -> . ,(cont 'b 'b)) 670 | -> . ,(cont 'a 'b))))))) 671 | nl) 672 | 673 | -------------------------------------------------------------------------------- /typechecking.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (defvar *debug* nil) 4 | 5 | (defun enable-debugging (&optional (enable-p t)) 6 | (setf *debug* enable-p)) 7 | 8 | (defun debug-format (&rest args) 9 | (when *debug* 10 | (apply #'format args))) 11 | 12 | (defgeneric typecheck-everything (type-checker &optional output)) 13 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pluggable-types) 2 | 3 | (defun parse-typed-lambda-list (lambda-list &key (normalize t) 4 | allow-specializers 5 | (normalize-optional normalize) 6 | (normalize-keyword normalize) 7 | (normalize-auxilary normalize)) 8 | "Parses a gradual lambda-list, returning as multiple values: 9 | 10 | 1. Required parameters. 11 | 12 | 2. Optional parameter specifications, normalized into form: 13 | 14 | (name init suppliedp) 15 | 16 | 3. Name of the rest parameter, or NIL. 17 | 18 | 4. Keyword parameter specifications, normalized into form: 19 | 20 | ((keyword-name name) init suppliedp) 21 | 22 | 5. Boolean indicating &ALLOW-OTHER-KEYS presence. 23 | 24 | 6. &AUX parameter specifications, normalized into form 25 | 26 | (name init). 27 | 28 | 7. Existence of &KEY in the lambda-list. 29 | 30 | Signals a PROGRAM-ERROR is the lambda-list is malformed." 31 | (let ((state :required) 32 | (allow-other-keys nil) 33 | (auxp nil) 34 | (required nil) 35 | (optional nil) 36 | (rest nil) 37 | (keys nil) 38 | (keyp nil) 39 | (aux nil)) 40 | (labels ((fail (elt) 41 | (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" 42 | elt lambda-list)) 43 | (check-variable (elt what &optional (allow-specializers allow-specializers)) 44 | (unless (and (or (symbolp elt) 45 | (and allow-specializers 46 | (consp elt) (= 2 (length elt)) (symbolp (first elt)))) 47 | (not (constantp elt))) 48 | (simple-program-error "Invalid ~A ~S in gradual lambda-list:~% ~S" 49 | what elt lambda-list))) 50 | (check-type-spec (type what) 51 | ;; TODO: how to verify a typespec is valid? symbolp is not enough 52 | #+nil(unless (symbolp type) 53 | (simple-program-error "Invalid ~A type spec ~A in typed lambda list:~% ~S" 54 | what 55 | type 56 | lambda-list))) 57 | (check-spec (spec what) 58 | (destructuring-bind (init &optional type suppliedp) spec 59 | (declare (ignore init)) 60 | (when type 61 | (check-type-spec type what)) 62 | (when suppliedp 63 | (check-variable suppliedp what nil))))) 64 | (dolist (elt lambda-list) 65 | (case elt 66 | (&optional 67 | (if (eq state :required) 68 | (setf state elt) 69 | (fail elt))) 70 | (&rest 71 | (if (member state '(:required &optional)) 72 | (setf state elt) 73 | (fail elt))) 74 | (&key 75 | (if (member state '(:required &optional :after-rest)) 76 | (setf state elt) 77 | (fail elt)) 78 | (setf keyp t)) 79 | (&allow-other-keys 80 | (if (eq state '&key) 81 | (setf allow-other-keys t 82 | state elt) 83 | (fail elt))) 84 | (&aux 85 | (cond ((eq state '&rest) 86 | (fail elt)) 87 | (auxp 88 | (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" 89 | elt lambda-list)) 90 | (t 91 | (setf auxp t 92 | state elt)) 93 | )) 94 | (otherwise 95 | (when (member elt '#.(set-difference lambda-list-keywords 96 | '(&optional &rest &key &allow-other-keys &aux))) 97 | (simple-program-error 98 | "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" 99 | elt lambda-list)) 100 | (case state 101 | (:required 102 | (if (listp elt) 103 | (progn 104 | (check-variable (first elt) "required parameter") 105 | (check-type-spec (second elt) "required parameter") 106 | (push elt required)) 107 | (progn 108 | (check-variable elt "required parameter") 109 | (push (list elt t) required)))) 110 | (&optional 111 | (cond ((consp elt) 112 | (destructuring-bind (name &rest tail) elt 113 | (check-variable name "optional parameter") 114 | (cond ((cdr tail) 115 | (check-spec tail "optional-supplied-p parameter")) 116 | (normalize-optional 117 | (setf elt (append elt '(t))))))) 118 | (t 119 | (check-variable elt "optional parameter") 120 | (when normalize-optional 121 | (setf elt (cons elt '(nil t)))))) 122 | (push (ensure-list elt) optional)) 123 | (&rest 124 | (if (consp elt) 125 | (destructuring-bind (var type) elt 126 | (check-variable var "rest parameter") 127 | (check-type-spec type "rest parameter") 128 | (setf rest elt)) 129 | ;; else 130 | (progn 131 | (check-variable elt "rest parameter") 132 | (setf rest (list elt t)))) 133 | (setf state :after-rest)) 134 | (&key 135 | (cond ((consp elt) 136 | (destructuring-bind (var-or-kv &rest tail) elt 137 | (cond ((consp var-or-kv) 138 | (destructuring-bind (keyword var) var-or-kv 139 | (unless (symbolp keyword) 140 | (simple-program-error "Invalid keyword name ~S in ordinary ~ 141 | lambda-list:~% ~S" 142 | keyword lambda-list)) 143 | (check-variable var "keyword parameter"))) 144 | (t 145 | (check-variable var-or-kv "keyword parameter") 146 | (when normalize-keyword 147 | (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)) 148 | ))) 149 | (if (cdr tail) 150 | (check-spec tail "keyword-supplied-p parameter") 151 | (when normalize-keyword 152 | (setf tail (append tail '(t))))) 153 | (setf elt (cons var-or-kv tail)))) 154 | (t 155 | (check-variable elt "keyword parameter") 156 | (setf elt (if normalize-keyword 157 | (list (list (make-keyword elt) elt) nil t) 158 | elt)))) 159 | (push elt keys)) 160 | (&aux 161 | (if (consp elt) 162 | (destructuring-bind (var &optional init) elt 163 | (declare (ignore init)) 164 | (check-variable var "&aux parameter")) 165 | (progn 166 | (check-variable elt "&aux parameter") 167 | (setf elt (list* elt (when normalize-auxilary 168 | '(nil)))))) 169 | (push elt aux)) 170 | (t 171 | (simple-program-error "Invalid typed lambda-list:~% ~S" lambda-list))))))) 172 | (values (nreverse required) (nreverse optional) rest (nreverse keys) 173 | allow-other-keys (nreverse aux) keyp))) 174 | 175 | (defun typed-lambda-list-to-normal (typed-lambda-list) 176 | (multiple-value-bind (required optional rest keys allow-other-keys aux) 177 | (parse-typed-lambda-list typed-lambda-list) 178 | (append (mapcar #'first required) 179 | (when optional 180 | (cons '&optional 181 | (mapcar (lambda (arg) 182 | (list (first arg) 183 | (second arg))) 184 | optional))) 185 | (when rest 186 | (cons '&rest (list (first rest)))) 187 | (when keys 188 | (cons '&key 189 | (mapcar (lambda (arg) 190 | (list (first arg) 191 | (second arg))) 192 | keys))) 193 | (when allow-other-keys 194 | (cons '&allow-other-keys 195 | allow-other-keys)) 196 | (when aux 197 | (cons '&aux aux))))) 198 | 199 | (defun types-lambda-list-to-normal (types-lambda-list) 200 | (multiple-value-bind (required optional rest keys allow-other-keys aux) 201 | (parse-types-lambda-list types-lambda-list) 202 | (append required 203 | (when optional 204 | (cons '&optional 205 | optional)) 206 | (when rest 207 | (cons '&rest (list rest))) 208 | (when keys 209 | (cons '&key 210 | (mapcar #'first 211 | keys))) 212 | (when allow-other-keys 213 | (cons '&allow-other-keys 214 | allow-other-keys)) 215 | (when aux 216 | (cons '&aux aux))))) 217 | 218 | (defun extract-type-declarations (declarations) 219 | (let* ((function-type-declarations 220 | (remove-if-not (lambda (x) 221 | (equalp x 'fun-type)) 222 | declarations 223 | :key #'caadr)) 224 | (var-type-declarations 225 | (remove-if-not (lambda (x) 226 | (equalp x 'var-type)) 227 | declarations 228 | :key #'caadr)) 229 | (return-type-declarations 230 | (remove-if-not (lambda (x) 231 | (equalp x 'return-type)) 232 | declarations 233 | :key #'caadr)) 234 | (other-declarations (set-difference declarations 235 | (append function-type-declarations 236 | var-type-declarations 237 | return-type-declarations)))) 238 | (values function-type-declarations 239 | var-type-declarations 240 | (first return-type-declarations) 241 | other-declarations))) 242 | 243 | (defun parse-types-lambda-list (lambda-list &key (normalize t) 244 | allow-specializers 245 | (normalize-optional normalize) 246 | (normalize-keyword normalize) 247 | (normalize-auxilary normalize)) 248 | "Parses a types lambda-list, returning as multiple values: 249 | 250 | 1. Required parameters. 251 | 252 | 2. Optional parameter specifications, normalized into form: 253 | 254 | (name init suppliedp) 255 | 256 | 3. Name of the rest parameter, or NIL. 257 | 258 | 4. Keyword parameter specifications, normalized into form: 259 | 260 | ((keyword-name name) init suppliedp) 261 | 262 | 5. Boolean indicating &ALLOW-OTHER-KEYS presence. 263 | 264 | 6. &AUX parameter specifications, normalized into form 265 | 266 | (name init). 267 | 268 | 7. Existence of &KEY in the lambda-list. 269 | 270 | Signals a PROGRAM-ERROR is the lambda-list is malformed." 271 | (let ((state :required) 272 | (allow-other-keys nil) 273 | (auxp nil) 274 | (required nil) 275 | (optional nil) 276 | (rest nil) 277 | (keys nil) 278 | (keyp nil) 279 | (aux nil)) 280 | (labels ((fail (elt) 281 | (simple-program-error "Misplaced ~S in types lambda-list:~% ~S" 282 | elt lambda-list)) 283 | (check-variable (elt what &optional (allow-specializers allow-specializers)) 284 | (unless (and (or (symbolp elt) 285 | (and allow-specializers 286 | (consp elt) (= 2 (length elt)) (symbolp (first elt)))) 287 | (not (constantp elt))) 288 | (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" 289 | what elt lambda-list))) 290 | (check-spec (spec what) 291 | (destructuring-bind (init suppliedp) spec 292 | (declare (ignore init)) 293 | (check-variable suppliedp what nil))) 294 | (check-type-spec (type what) 295 | ;; TODO: verify type spec validity. symbolp is not enough 296 | #+nil(unless (symbolp type) 297 | (simple-program-error "Invalid ~A type spec ~A in types lambda list:~% ~S" 298 | what 299 | type 300 | lambda-list)))) 301 | (dolist (elt lambda-list) 302 | (case elt 303 | (&optional 304 | (if (eq state :required) 305 | (setf state elt) 306 | (fail elt))) 307 | (&rest 308 | (if (member state '(:required &optional)) 309 | (setf state elt) 310 | (fail elt))) 311 | (&key 312 | (if (member state '(:required &optional :after-rest)) 313 | (setf state elt) 314 | (fail elt)) 315 | (setf keyp t)) 316 | (&allow-other-keys 317 | (if (eq state '&key) 318 | (setf allow-other-keys t 319 | state elt) 320 | (fail elt))) 321 | (&aux 322 | (cond ((eq state '&rest) 323 | (fail elt)) 324 | (auxp 325 | (simple-program-error "Multiple ~S in types lambda-list:~% ~S" 326 | elt lambda-list)) 327 | (t 328 | (setf auxp t 329 | state elt)) 330 | )) 331 | (otherwise 332 | (when (member elt '#.(set-difference lambda-list-keywords 333 | '(&optional &rest &key &allow-other-keys &aux))) 334 | (simple-program-error 335 | "Bad lambda-list keyword ~S in types lambda-list:~% ~S" 336 | elt lambda-list)) 337 | (case state 338 | (:required 339 | (check-type-spec elt "required parameter") 340 | (push elt required)) 341 | (&optional 342 | (check-type-spec elt "optional parameter") 343 | (push elt optional)) 344 | (&rest 345 | (check-type-spec elt "rest parameter") 346 | (setf rest elt 347 | state :after-rest)) 348 | (&key 349 | (when (not (and (consp elt) 350 | (equalp (length elt) 2))) 351 | (simple-program-error "Invalid keyword type spec ~A in lambda-list:~% ~S" 352 | elt 353 | lambda-list)) 354 | (destructuring-bind (var type) elt 355 | (check-variable var "keyword parameter") 356 | (check-type-spec type "keyword parameter") 357 | (push (cons (car elt) (cadr elt)) keys))) 358 | (&aux 359 | (if (consp elt) 360 | (destructuring-bind (var &optional init) elt 361 | (declare (ignore init)) 362 | (check-variable var "&aux parameter")) 363 | (progn 364 | (check-variable elt "&aux parameter") 365 | (setf elt (list* elt (when normalize-auxilary 366 | '(nil)))))) 367 | (push elt aux)) 368 | (t 369 | (simple-program-error "Invalid types lambda-list:~% ~S" lambda-list))))))) 370 | (values (nreverse required) (nreverse optional) rest (nreverse keys) 371 | allow-other-keys (nreverse aux) keyp))) 372 | 373 | #+util 374 | (defun format-readme () 375 | (clhs-linker:link-file 376 | (asdf:system-relative-pathname :pluggable-types "README.source.md") 377 | (asdf:system-relative-pathname :pluggable-types "README.md"))) 378 | --------------------------------------------------------------------------------