├── .github └── workflows │ └── test.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _oasis ├── configure ├── lib ├── syb.ml ├── syb_classes.ml ├── syb_classes.mli ├── syb_constructors.ml ├── syb_constructors.mli ├── syb_instances.ml ├── syb_instances.mli ├── syb_schemes.ml └── syb_schemes.mli ├── opam ├── setup.ml └── test └── test_syb.ml /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: SYB 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | branches: 8 | - master 9 | jobs: 10 | install: 11 | name: Install 12 | runs-on: ${{ matrix.os }} 13 | env: 14 | ACTIONS_ALLOW_UNSECURE_COMMANDS: 'true' 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | ocaml-compiler: ["ocaml-variants.4.02.1+modular-implicits", "ocaml-variants.4.02.1+modular-implicits-ber"] 19 | os: [ubuntu-latest] 20 | steps: 21 | 22 | - name: Checkout code 23 | uses: actions/checkout@v2 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 26 | uses: ocaml/setup-ocaml@v2 27 | if: steps.cache-dependencies.outputs.cache-hit != 'true' 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 30 | dune-cache: true 31 | 32 | - name: Build 33 | run: | 34 | opam pin add -t --yes . 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _build 3 | setup.data 4 | setup.log 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Jeremy Yallop 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A port of the [Scrap Your Boilerplate][syb-haskell] library to OCaml with [modular implicits][modimpl]. 2 | 3 | ### Installation 4 | 5 | ![build status](https://github.com/yallop/ocaml-syb/workflows/SYB/badge.svg) 6 | 7 | ``` 8 | opam switch 4.02.1+modular-implicits 9 | opam pin add syb https://github.com/yallop/ocaml-syb.git 10 | ``` 11 | 12 | ### Usage 13 | 14 | The following examples assume that you have loaded the package and brought the instances into scope: 15 | 16 | ```ocaml 17 | # #require "syb";; 18 | # open Syb.Instances;; 19 | ``` 20 | 21 | Apply `succ` to every `int` within a larger structure: 22 | 23 | ```ocaml 24 | # Syb.(everywhere (mkT succ)) [1;2;3];; 25 | - : int list = [2; 3; 4] 26 | ``` 27 | 28 | Apply `not` to every `bool` within a larger structure: 29 | 30 | ```ocaml 31 | # Syb.(everywhere (mkT not)) [[true], 1; [], 2; [true; false], 3];; 32 | - : (bool list * int) list = [([false], 1); ([], 2); ([false; true], 3)] 33 | ``` 34 | 35 | Collect all `int` values less than `3`: 36 | 37 | ```ocaml 38 | # Syb.listify (fun x -> x < 3) [[(4, true)]; [(-2, false); (1, false)]; []; [0, true]];; 39 | - : int list = [-2; 1; 0] 40 | ``` 41 | 42 | ### See also 43 | 44 | * [metaocaml-syb]: a version of ocaml-syb for [BER MetaOCaml][ber], which uses staging to significantly improve performance 45 | 46 | [syb-haskell]: http://foswiki.cs.uu.nl/foswiki/GenericProgramming/SYB 47 | [modimpl]: http://www.lpw25.net/ml2014.pdf 48 | [metaocaml-syb]: https://github.com/yallop/metaocaml-syb 49 | [ber]: http://okmij.org/ftp/ML/MetaOCaml.html 50 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: syb 3 | Version: 0.1 4 | Synopsis: Scrap Your Boilerplate for OCaml with modular implicits 5 | Authors: Jeremy Yallop 6 | BuildTools: ocamlbuild 7 | License: MIT 8 | Plugins: META (0.4), DevFiles (0.4) 9 | 10 | Library syb 11 | Path: lib 12 | Findlibname: syb 13 | BuildTools: ocamlbuild 14 | Modules: Syb, Syb_classes, Syb_instances 15 | InternalModules: Syb_constructors, Syb_schemes 16 | BuildDepends: higher 17 | 18 | Executable test_syb 19 | Path: test 20 | MainIs: test_syb.ml 21 | Build$: flag(tests) 22 | Install: false 23 | BuildDepends: oUnit, syb 24 | 25 | Test test_syb 26 | Command: $test_syb 27 | WorkingDirectory: test 28 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /lib/syb.ml: -------------------------------------------------------------------------------- 1 | include Syb_classes 2 | module Instances = Syb_instances 3 | include Syb_schemes 4 | -------------------------------------------------------------------------------- /lib/syb_classes.ml: -------------------------------------------------------------------------------- 1 | (* SYB-style equality, using extensible variants to avoid the unsafe cast. *) 2 | 3 | open Higher 4 | 5 | (* Equality *) 6 | type (_, _) eql = Refl : ('a, 'a) eql 7 | 8 | (* Type representations *) 9 | type _ type_rep = .. 10 | 11 | (* Our analogue to the typeable class *) 12 | module type TYPEABLE = 13 | sig 14 | type t 15 | val type_rep : unit -> t type_rep 16 | val eqty : 's type_rep -> (t, 's) eql option 17 | end 18 | 19 | let (=~~=) {A: TYPEABLE} {B: TYPEABLE} = A.eqty (B.type_rep ()) 20 | 21 | (* Implicit instances *) 22 | module rec R : 23 | sig 24 | type genericT = {D:R.DATA} -> D.t -> D.t 25 | and 'u genericQ = {D:R.DATA} -> D.t -> 'u 26 | and 'c genericFapp = 27 | < g: 'b. {T: R.DATA} -> (T.t -> 'b, 'c) app -> T.t -> ('b, 'c) app > 28 | and 'c genericFunit = < u: 'g. 'g -> ('g, 'c) app > 29 | 30 | module type DATA = 31 | sig 32 | type t 33 | module Typeable : TYPEABLE with type t = t 34 | val gmapT : genericT -> t -> t 35 | val gmapQ : 'u genericQ -> t -> 'u list 36 | val gfoldl : 'c genericFapp -> 'c genericFunit -> t -> (t, 'c) app 37 | val constructor: t -> Syb_constructors.constructor 38 | end 39 | end = R 40 | include R 41 | 42 | let gmapT f {D: DATA} = D.gmapT f 43 | let gmapQ f {D: DATA} = D.gmapQ f 44 | let gfoldl f u {D: DATA} = D.gfoldl f u 45 | let constructor {D: DATA} = D.constructor 46 | 47 | let app (type a) (type b) (module A : TYPEABLE with type t = a) 48 | (b : b type_rep) (g : b -> b) (x : a) : a = 49 | match A.eqty b with 50 | | Some Refl -> g x 51 | | _ -> x 52 | 53 | let app' (type a) (type b) (type u) (module A : TYPEABLE with type t = a) 54 | (b : b type_rep) (u: u) (g : b -> u) (x: a) : u = 55 | match A.eqty b with 56 | | Some Refl -> g x 57 | | _ -> u 58 | 59 | let mkT : {T:TYPEABLE} -> (T.t -> T.t) -> genericT = 60 | fun {T:TYPEABLE} g {D: DATA} -> 61 | app (module D.Typeable) (T.type_rep ()) g 62 | 63 | let mkQ : 'u. {T:TYPEABLE} -> 'u -> (T.t -> 'u) -> 'u genericQ = 64 | fun {T:TYPEABLE} u g {D: DATA} x -> 65 | app' (module D.Typeable) (T.type_rep ()) u g x 66 | -------------------------------------------------------------------------------- /lib/syb_classes.mli: -------------------------------------------------------------------------------- 1 | open Higher 2 | 3 | (* Equality *) 4 | type (_, _) eql = Refl : ('a, 'a) eql 5 | 6 | (* Type representations *) 7 | type _ type_rep = .. 8 | 9 | (* Our analogue to the typeable class *) 10 | module type TYPEABLE = 11 | sig 12 | type t 13 | val type_rep : unit -> t type_rep 14 | val eqty : 's type_rep -> (t, 's) eql option 15 | end 16 | 17 | (* Equality test *) 18 | val (=~~=) : {A:TYPEABLE} -> {B:TYPEABLE} -> (A.t, B.t) eql option 19 | 20 | module rec R : 21 | sig 22 | type genericT = {T: R.DATA} -> T.t -> T.t 23 | type 'u genericQ = {T: R.DATA} -> T.t -> 'u 24 | type 'c genericFapp = 25 | < g: 'b. {T: R.DATA} -> (T.t -> 'b, 'c) app -> T.t -> ('b, 'c) app > 26 | type 'c genericFunit = < u: 'g. 'g -> ('g, 'c) app > 27 | module type DATA = 28 | sig 29 | type t 30 | module Typeable : TYPEABLE with type t = t 31 | val gmapT : genericT -> t -> t 32 | val gmapQ : 'u genericQ -> t -> 'u list 33 | val gfoldl : 'c genericFapp -> 'c genericFunit -> t -> (t, 'c) app 34 | val constructor: t -> Syb_constructors.constructor 35 | end 36 | end 37 | include module type of R 38 | 39 | val gmapT : genericT -> genericT 40 | val gmapQ : 'u genericQ -> 'u list genericQ 41 | val gfoldl : 'c genericFapp -> 'c genericFunit -> 42 | {T: DATA} -> T.t -> (T.t, 'c) app 43 | val constructor : Syb_constructors.constructor genericQ 44 | 45 | val mkT : {T:TYPEABLE} -> (T.t -> T.t) -> genericT 46 | val mkQ : {T:TYPEABLE} -> 'u -> (T.t -> 'u) -> 'u genericQ 47 | -------------------------------------------------------------------------------- /lib/syb_constructors.ml: -------------------------------------------------------------------------------- 1 | type constructor = string 2 | 3 | let constructor c = c 4 | let string_of_constructor c = c 5 | -------------------------------------------------------------------------------- /lib/syb_constructors.mli: -------------------------------------------------------------------------------- 1 | type constructor = string 2 | 3 | val constructor : string -> constructor 4 | val string_of_constructor : constructor -> string 5 | -------------------------------------------------------------------------------- /lib/syb_instances.ml: -------------------------------------------------------------------------------- 1 | open Syb_constructors 2 | open Syb_classes 3 | 4 | (* Some primitive typeable instances *) 5 | type _ type_rep += List : 'a type_rep -> 'a list type_rep 6 | type _ type_rep += Option : 'a type_rep -> 'a option type_rep 7 | type _ type_rep += Pair : 'a type_rep * 'b type_rep -> ('a * 'b) type_rep 8 | 9 | module Typeable0_make(T: sig type t end) = 10 | struct 11 | type _ type_rep += T : T.t type_rep 12 | type t = T.t 13 | let eqty : type b. b type_rep -> (t, b) eql option = 14 | function T -> Some Refl | _ -> None 15 | let type_rep () = T 16 | end 17 | 18 | implicit module Typeable_int = Typeable0_make(struct type t = int end) 19 | implicit module Typeable_bool = Typeable0_make(struct type t = bool end) 20 | implicit module Typeable_float = Typeable0_make(struct type t = float end) 21 | implicit module Typeable_string = Typeable0_make(struct type t = string end) 22 | 23 | implicit module Typeable_pair{A: TYPEABLE} {B: TYPEABLE} = 24 | struct 25 | type t = A.t * B.t 26 | let eqty : type c. c type_rep -> (A.t * B.t, c) eql option = function 27 | Pair (a, b) -> 28 | begin match A.eqty a, B.eqty b with 29 | Some Refl, Some Refl -> Some Refl 30 | | _ -> None 31 | end 32 | | _ -> None 33 | 34 | let type_rep () = Pair (A.type_rep (), B.type_rep ()) 35 | end 36 | 37 | implicit module Typeable_list{A: TYPEABLE} = 38 | struct 39 | type t = A.t list 40 | let eqty : type b. b type_rep -> (A.t list, b) eql option = function 41 | | List a -> 42 | begin match A.eqty a with 43 | Some Refl -> Some Refl 44 | | None -> None 45 | end 46 | | _ -> None 47 | let type_rep () = List (A.type_rep ()) 48 | end 49 | 50 | implicit module Typeable_option{A: TYPEABLE} = 51 | struct 52 | type t = A.t option 53 | let eqty : type b. b type_rep -> (A.t option, b) eql option = function 54 | | Option a -> 55 | begin match A.eqty a with 56 | Some Refl -> Some Refl 57 | | None -> None 58 | end 59 | | _ -> None 60 | let type_rep () = Option (A.type_rep ()) 61 | end 62 | 63 | module Primitive(A: 64 | sig 65 | type t 66 | module Typeable : TYPEABLE with type t = t 67 | val constructor : t -> constructor 68 | end) : DATA with type t = A.t = 69 | struct 70 | include A 71 | let gmapT _ x = x 72 | let gmapQ _ _ = [] 73 | let gfoldl (g : _ genericFapp) (u : _ genericFunit) x = u#u x 74 | end 75 | 76 | implicit module Data_int = 77 | Primitive (struct 78 | type t = int 79 | module Typeable = Typeable_int 80 | let constructor c = Syb_constructors.constructor (string_of_int c) 81 | end) 82 | 83 | implicit module Data_bool = 84 | Primitive (struct 85 | type t = bool 86 | module Typeable = Typeable_bool 87 | let constructor b = Syb_constructors.constructor (string_of_bool b) 88 | end) 89 | 90 | implicit module Data_float = 91 | Primitive (struct 92 | type t = float 93 | module Typeable = Typeable_float 94 | let constructor f = Syb_constructors.constructor (string_of_float f) 95 | end) 96 | 97 | implicit module Data_string = 98 | Primitive (struct 99 | type t = string 100 | module Typeable = Typeable_string 101 | let constructor s = Syb_constructors.constructor (Printf.sprintf "%S" s) 102 | end) 103 | 104 | implicit module Data_list {A: DATA} : DATA with type t = A.t list = 105 | struct 106 | module rec R : DATA with type t = A.t list = 107 | struct 108 | type t = A.t list 109 | module Typeable = Typeable_list{A.Typeable} 110 | let gmapT (f : genericT) (l : t) = 111 | match l with 112 | [] -> [] 113 | | x :: xs -> f x :: f {R} xs 114 | 115 | let gmapQ (q : _ genericQ) (l : t) = 116 | match l with 117 | [] -> [] 118 | | x :: xs -> [q x; q {R} xs] 119 | 120 | let gfoldl (g : _ genericFapp) (u : _ genericFunit) l = 121 | match l with 122 | [] -> u#u l 123 | | x :: xs -> g#g {R} (g#g (u#u (fun x xs -> x :: xs)) x) xs 124 | 125 | let constructor = function 126 | [] -> Syb_constructors.constructor "[]" 127 | | _::_ -> Syb_constructors.constructor "::" 128 | end 129 | include R 130 | end 131 | 132 | implicit module Data_pair {A: DATA} {B: DATA} : DATA with type t = A.t * B.t = 133 | struct 134 | type t = A.t * B.t 135 | module Typeable = Typeable_pair{A.Typeable}{B.Typeable} 136 | let gmapT (f : genericT) ((x, y) : t) = (f x, f y) 137 | let gmapQ (q : _ genericQ) ((x, y) : t) = [q x; q y] 138 | let gfoldl (g : _ genericFapp) (u : _ genericFunit) (x, y) = 139 | g#g {B} (g#g {A} (u#u (fun x y -> (x,y))) x) y 140 | let constructor _ = "(,)" 141 | end 142 | 143 | implicit module Data_option {A: DATA} : DATA with type t = A.t option = 144 | struct 145 | type t = A.t option 146 | module Typeable = Typeable_option{A.Typeable} 147 | let gmapT (f : genericT) (o : t) = 148 | match o with None -> None | Some x -> Some (f x) 149 | let gmapQ (q : _ genericQ) (o : t) = 150 | match o with None -> [] | Some x -> [q x] 151 | let gfoldl (g : _ genericFapp) (u : _ genericFunit) = function 152 | None -> u#u None 153 | | Some x -> g#g {A} (u#u (fun x -> Some x)) x 154 | let constructor = function 155 | None -> "None" 156 | | Some _ -> "Some" 157 | end 158 | 159 | implicit module Typeable_of_data{F: DATA} = F.Typeable 160 | -------------------------------------------------------------------------------- /lib/syb_instances.mli: -------------------------------------------------------------------------------- 1 | open Syb_classes 2 | 3 | (* Data instances for built-in types *) 4 | implicit module Data_int : DATA with type t = int 5 | implicit module Data_bool : DATA with type t = bool 6 | implicit module Data_float : DATA with type t = float 7 | implicit module Data_string : DATA with type t = string 8 | implicit module Data_list {A: DATA} : DATA with type t = A.t list 9 | implicit module Data_pair {A: DATA} {B: DATA} : DATA with type t = A.t * B.t 10 | implicit module Data_option {A: DATA} : DATA with type t = A.t option 11 | 12 | module Typeable_int : TYPEABLE with type t = int 13 | module Typeable_bool : TYPEABLE with type t = bool 14 | module Typeable_float : TYPEABLE with type t = float 15 | module Typeable_string : TYPEABLE with type t = string 16 | module Typeable_list {A: TYPEABLE} : TYPEABLE with type t = A.t list 17 | module Typeable_pair {A: TYPEABLE} {B: TYPEABLE} : TYPEABLE with type t = A.t * B.t 18 | module Typeable_option {A: TYPEABLE} : TYPEABLE with type t = A.t option 19 | (* module Typeable_either {A: TYPEABLE} {B: TYPEABLE} : TYPEABLE with type t = (A.t, B.t) either *) 20 | 21 | implicit module Typeable_of_data {A: DATA} : TYPEABLE with type t = A.t 22 | -------------------------------------------------------------------------------- /lib/syb_schemes.ml: -------------------------------------------------------------------------------- 1 | open Syb_constructors 2 | open Syb_classes 3 | 4 | (* Various utilities *) 5 | let unjust l o = match o with Some x -> x :: l | None -> l 6 | let singleton = function [s] -> Some s | _ -> None 7 | let sum l = List.fold_left (+) 0 l 8 | let maximum = List.fold_left max 0 9 | 10 | 11 | (** Apply a transformation everywhere in bottom-up manner *) 12 | let rec everywhere : genericT -> genericT = 13 | fun (f : genericT) {X:DATA} x -> f ((gmapT (everywhere f) : genericT) x) 14 | 15 | 16 | (** Apply a transformation everywhere in top-down manner *) 17 | let rec everywhere' : genericT -> genericT = 18 | fun (f : genericT) {X:DATA} x -> (gmapT (everywhere' f) : genericT) (f x) 19 | 20 | 21 | (** Variation on everywhere with an extra stop condition *) 22 | let rec everywhereBut : bool genericQ -> genericT -> genericT = 23 | fun (stop : bool genericQ) (f : genericT) {X:DATA} x -> 24 | if stop x then x else f ((gmapT (everywhereBut stop f) : genericT) x) 25 | 26 | 27 | (** Monadic variation on everywhere *) 28 | (* [TODO]: everywhereM *) 29 | 30 | 31 | (** Apply a monadic transformation at least somewhere *) 32 | (* [TODO]: somewhere *) 33 | 34 | 35 | (** Summarise all nodes in top-down, left-to-right order *) 36 | let rec everything : 'r. ('r -> 'r -> 'r) -> 'r genericQ -> 'r genericQ = 37 | fun (@) g {X: DATA} x -> 38 | let f = g x in List.fold_left (@) f (gmapQ (everything (@) g) x) 39 | 40 | 41 | (** Variation of "everything" with an added stop condition *) 42 | let rec everythingBut : 'r. ('r -> 'r -> 'r) -> ('r * bool) genericQ -> 'r genericQ = 43 | fun (@) (stop : _ genericQ) {X: DATA} x -> 44 | match stop x with 45 | | v, true -> v 46 | | v, false -> List.fold_left (@) v (gmapQ (everythingBut (@) stop) x) 47 | 48 | 49 | (** Summarise all nodes in top-down, left-to-right order, carrying some state 50 | down the tree during the computation, but not left-to-right to 51 | siblings. *) 52 | (* [TODO]: everythingWithContext *) 53 | 54 | 55 | (** Get a list of all entities that meet a predicate *) 56 | let listify {R:TYPEABLE} p = 57 | everything (@) (mkQ [] (fun x -> if p x then [x] else [])) 58 | 59 | 60 | (** Look up a subterm by means of a maybe-typed filter *) 61 | (* [TODO]: something *) 62 | 63 | 64 | (** Bottom-up synthesis of a data structure; 65 | 1st argument z is the initial element for the synthesis; 66 | 2nd argument o is for reduction of results from subterms; 67 | 3rd argument f updates the synthesised data according to the given term 68 | *) 69 | let rec synthesize : 70 | 's 't.'s -> ('t -> 's -> 's) -> ('s -> 't) genericQ -> 't genericQ = 71 | fun z o (f : _ genericQ) {X: DATA} x -> 72 | f x (List.fold_right o (gmapQ (synthesize z o f) x) z) 73 | 74 | 75 | (** Compute size of an arbitrary data structure *) 76 | let rec gsize {D:DATA} v = 1 + sum (gmapQ gsize v) 77 | 78 | 79 | (** Count the number of immediate subterms of the given term *) 80 | let glength {T: DATA} x = List.length (gmapQ (fun {Z:DATA} _ -> ()) x) 81 | 82 | 83 | (** Determine depth of the given term *) 84 | let rec gdepth {D: DATA} x = succ (maximum (gmapQ gdepth x)) 85 | 86 | 87 | (** Determine the number of all suitable nodes in a given term *) 88 | let gcount (p : bool genericQ) {T: DATA} x = 89 | everything (+) 90 | (fun {X: DATA} x -> if p x then 1 else 0 ) 91 | x 92 | 93 | 94 | (** Determine the number of all nodes in a given term *) 95 | let gnodecount {X: DATA} x = gcount (fun {Y: DATA} _ -> true ) x 96 | 97 | 98 | (** Determine the number of nodes of a given type in a given term *) 99 | let gtypecount {X:TYPEABLE} x = gcount (mkQ false (fun _ -> true)) 100 | 101 | 102 | (** Find (unambiguously) an immediate subterm of a given type *) 103 | let gfindtype {X:TYPEABLE} {D: DATA} x = 104 | singleton (List.fold_left unjust [] 105 | (gmapQ (mkQ None (fun c -> Some c)) x)) 106 | 107 | 108 | (** Generic show *) 109 | let rec gshow {D:DATA} v = 110 | "("^ string_of_constructor (constructor v) 111 | ^ String.concat " " (gmapQ gshow v) 112 | ^ ")" 113 | -------------------------------------------------------------------------------- /lib/syb_schemes.mli: -------------------------------------------------------------------------------- 1 | open Syb_classes 2 | 3 | (** Apply a transformation everywhere in bottom-up manner *) 4 | val everywhere : genericT -> genericT 5 | 6 | (** Apply a transformation everywhere in top-down manner *) 7 | val everywhere' : genericT -> genericT 8 | 9 | (** Variation on everywhere with an extra stop condition *) 10 | val everywhereBut : bool genericQ -> genericT -> genericT 11 | 12 | (** Monadic variation on everywhere *) 13 | (* val everywhereM : (Data a, Monad m) => GenericM m -> a -> m a *) 14 | 15 | (** Apply a monadic transformation at least somewhere *) 16 | (* val somewhere : (MonadPlus m, Data a) => GenericM m -> a -> m a *) 17 | 18 | (** Summarise all nodes in top-down, left-to-right order *) 19 | val everything : ('r -> 'r -> 'r) -> 'r genericQ -> 'r genericQ 20 | 21 | (** Variation of "everything" with an added stop condition *) 22 | val everythingBut : ('r -> 'r -> 'r) -> ('r * bool) genericQ -> 'r genericQ 23 | 24 | (** Summarise all nodes in top-down, left-to-right order, carrying some state 25 | down the tree during the computation, but not left-to-right to 26 | siblings. *) 27 | (* 28 | val everythingWithContext : {X: Data} -> 's -> ('r -> 'r -> 'r) -> 29 | ({Y:Data} -> Y.t code -> 's code -> ('r * 's) code) -> 30 | X.t code -> 'r code 31 | *) 32 | 33 | (** Get a list of all entities that meet a predicate *) 34 | val listify : {R:TYPEABLE} -> (R.t -> bool) -> R.t list genericQ 35 | 36 | (** Look up a subterm by means of a maybe-typed filter *) 37 | (* 38 | val something : 'u option genericQ -> 'u option genericQ 39 | *) 40 | 41 | (** Bottom-up synthesis of a data structure; 42 | 1st argument z is the initial element for the synthesis; 43 | 2nd argument o is for reduction of results from subterms; 44 | 3rd argument f updates the synthesised data according to the given term 45 | *) 46 | val synthesize : 's -> ('t -> 's -> 's) -> ('s -> 't) genericQ -> 't genericQ 47 | 48 | (** Compute size of an arbitrary data structure *) 49 | val gsize : int genericQ 50 | 51 | (** Count the number of immediate subterms of the given term *) 52 | val glength : int genericQ 53 | 54 | (** Determine depth of the given term *) 55 | val gdepth : int genericQ 56 | 57 | (** Determine the number of all suitable nodes in a given term *) 58 | val gcount : bool genericQ -> int genericQ 59 | 60 | (** Determine the number of all nodes in a given term *) 61 | val gnodecount : int genericQ 62 | 63 | (** Determine the number of nodes of a given type in a given term *) 64 | val gtypecount : {X:TYPEABLE} -> X.t -> int genericQ 65 | 66 | (** Find (unambiguously) an immediate subterm of a given type *) 67 | val gfindtype : {X:TYPEABLE} -> X.t option genericQ 68 | 69 | (** Generic show *) 70 | val gshow : string genericQ 71 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "syb" 3 | version: "dev" 4 | maintainer: "yallop@gmail.com" 5 | author: "yallop@gmail.com" 6 | homepage: "https://github.com/yallop/ocaml-syb" 7 | dev-repo: "http://github.com/yallop/ocaml-syb.git" 8 | bug-reports: "http://github.com/yallop/ocaml-syb/issues" 9 | license: "MIT" 10 | build: [ 11 | ["./configure" "--enable-tests"] 12 | [make] 13 | [make "test"] {with-test} 14 | ] 15 | install: [ 16 | [make "install"] 17 | ] 18 | remove: [ 19 | ["ocamlfind" "remove" "syb"] 20 | ] 21 | depends: [ 22 | "ounit" {build} 23 | "ocamlfind" {build} 24 | "oasis" {build} 25 | "higher" 26 | ] 27 | available: [ compiler = "4.02.1+modular-implicits" 28 | | compiler = "4.02.1+modular-implicits-ber" ] 29 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.4.5 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) 5 | (******************************************************************************) 6 | (* OASIS: architecture for building OCaml libraries and applications *) 7 | (* *) 8 | (* Copyright (C) 2011-2013, Sylvain Le Gall *) 9 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 10 | (* *) 11 | (* This library is free software; you can redistribute it and/or modify it *) 12 | (* under the terms of the GNU Lesser General Public License as published by *) 13 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 14 | (* your option) any later version, with the OCaml static compilation *) 15 | (* exception. *) 16 | (* *) 17 | (* This library is distributed in the hope that it will be useful, but *) 18 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 19 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 20 | (* details. *) 21 | (* *) 22 | (* You should have received a copy of the GNU Lesser General Public License *) 23 | (* along with this library; if not, write to the Free Software Foundation, *) 24 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 25 | (******************************************************************************) 26 | 27 | let () = 28 | try 29 | Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 30 | with Not_found -> () 31 | ;; 32 | #use "topfind";; 33 | #require "oasis.dynrun";; 34 | open OASISDynRun;; 35 | 36 | (* OASIS_STOP *) 37 | let () = setup ();; 38 | -------------------------------------------------------------------------------- /test/test_syb.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Higher 3 | open Syb_classes 4 | open Syb_schemes 5 | open Syb_instances 6 | 7 | let test_gshow _ = 8 | assert_equal ~printer:(fun x -> x) 9 | "(::((,)(true) (1)) (::((,)(false) (2)) (::((,)(false) (3)) ([]))))" 10 | (gshow 11 | [(true, 1); 12 | (false, 2); 13 | (false, 3)]) 14 | 15 | let test_gsize _ = 16 | assert_equal ~printer:string_of_int 17 | 13 18 | (gsize 19 | [(true, 1); 20 | (false, 2); 21 | (false, 3)]) 22 | 23 | let test_everywhere _ = 24 | assert_equal 25 | [(false, 1); 26 | (true, 2); 27 | (true, 3)] 28 | ((everywhere (mkT not)) 29 | [(true, 1); 30 | (false, 2); 31 | (false, 3)]) 32 | 33 | 34 | let test_everywhere' _ = 35 | assert_equal 36 | [(false, 1); 37 | (true, 2); 38 | (true, 3)] 39 | ((everywhere' (mkT not)) 40 | [(true, 1); 41 | (false, 2); 42 | (false, 3)]) 43 | 44 | let test_everything _ = 45 | let ints_gt_0 = mkQ [] (fun x -> if x > 0 then [x] else []) in 46 | assert_equal 47 | [1; 2; 3; 20] 48 | ((everything (@) ints_gt_0) 49 | [(false, 1); 50 | (true, 2); 51 | (true, 3); 52 | (true, -10); 53 | (false, 20); 54 | ]) 55 | 56 | let test_instantiate_everywhere_without_function _ = 57 | assert_equal 58 | [(false, 2); 59 | (true, 3); 60 | (false, 4)] 61 | (everywhere (mkT succ) 62 | [(false, 1); 63 | (true, 2); 64 | (false, 3)]) 65 | 66 | 67 | let test_gfoldl_gmap _ = 68 | let module Definitions = 69 | struct 70 | module Id = Newtype1(struct type 'a t = 'a end) 71 | (* gmapT in terms of gfoldl *) 72 | let gmapT (f : genericT) : genericT = 73 | let f : _ genericFapp = 74 | object 75 | method g: 'b. {T: R.DATA} -> (T.t -> 'b, 'c) app -> T.t -> ('b, 'c) app = 76 | fun {T: R.DATA} g x -> Id.inj (Id.prj g (f x)) 77 | end 78 | and u : _ genericFunit = 79 | object 80 | method u: 'g. 'g -> ('g, 'c) app = Id.inj 81 | end in 82 | fun {D:DATA} (x: D.t) -> Id.prj (D.gfoldl f u x) 83 | 84 | let rec everywhere : genericT -> genericT = 85 | fun (f : genericT) {X:DATA} x -> f ((gmapT (everywhere f) : genericT) x) 86 | end 87 | in 88 | assert_equal 89 | [(false, 1); 90 | (true, 2); 91 | (true, 3)] 92 | ((Definitions.everywhere (mkT not)) 93 | [(true, 1); 94 | (false, 2); 95 | (false, 3)]) 96 | 97 | 98 | let suite = "SYB tests" >::: 99 | ["gshow" 100 | >:: test_gshow; 101 | 102 | "gsize" 103 | >:: test_gsize; 104 | 105 | "everywhere" 106 | >:: test_everywhere; 107 | 108 | "everywhere'" 109 | >:: test_everywhere'; 110 | 111 | "everything" 112 | >:: test_everything; 113 | 114 | "everything without function" 115 | >:: test_instantiate_everywhere_without_function; 116 | 117 | "everywhere using gfoldl" 118 | >:: test_gfoldl_gmap; 119 | ] 120 | 121 | 122 | let _ = 123 | run_test_tt_main suite 124 | --------------------------------------------------------------------------------