Last active
July 23, 2025 20:17
-
-
Save Skyb0rg007/2383bc598a3b8cb448d9b76603f5c796 to your computer and use it in GitHub Desktop.
smlnj bug 2025-07-23
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (** Signatures **) | |
| signature FUNCTOR = | |
| sig | |
| type 'a t | |
| val map : ('a -> 'b) -> 'a t -> 'b t | |
| end | |
| signature RECURSIVE = | |
| sig | |
| type t | |
| type 'a base | |
| val project : t -> t base | |
| val embed : t base -> t | |
| end | |
| signature COMONAD = | |
| sig | |
| include FUNCTOR | |
| val extract : 'a t -> 'a | |
| val duplicate : 'a t -> 'a t t | |
| end | |
| signature DISTRIBUTION_LAW' = | |
| sig | |
| structure W : COMONAD | |
| structure F : FUNCTOR | |
| val dist : 'a W.t F.t -> 'a F.t W.t | |
| end | |
| (** Folds **) | |
| functor GeneralizedCatamorphism( | |
| structure T : RECURSIVE | |
| structure D : DISTRIBUTION_LAW' where type 'a F.t = 'a T.base) = | |
| struct | |
| structure F = D.F | |
| structure W = D.W | |
| type t = T.t | |
| type 'a f = 'a F.t | |
| type 'a w = 'a W.t | |
| fun cata g = let | |
| fun c x = D.dist (F.map (W.duplicate o W.map g o c) (T.project x)) | |
| in | |
| fn a => g (W.extract (c a)) | |
| end | |
| end | |
| (* Helper *) | |
| structure Identity = | |
| struct | |
| type 'a t = 'a | |
| fun map f x = f x | |
| val pure = Fn.id | |
| val join = Fn.id | |
| val extract = Fn.id | |
| val duplicate = Fn.id | |
| end | |
| (* Distribution Laws *) | |
| (* Catamorphism: every functor distributes over the identity monad *) | |
| functor CatamorphismDist(F : FUNCTOR) : DISTRIBUTION_LAW' = | |
| struct | |
| structure F = F | |
| structure W = Identity | |
| val dist = Fn.id | |
| end | |
| (* Histomorphism: Convert a distribution law into one that tracks history *) | |
| functor HistomorphismDist(D : DISTRIBUTION_LAW') = | |
| struct | |
| structure F = D.F | |
| structure W = | |
| struct | |
| datatype 'a t = Cofree of ('a * 'a t F.t) D.W.t | |
| fun map f (Cofree w) = Cofree (D.W.map (fn (x, y) => (f x, F.map (map f) y)) w) | |
| fun extract (Cofree w) = #1 (D.W.extract w) | |
| fun duplicate (Cofree w) = Cofree (D.W.map (fn w' => (Cofree w', F.map duplicate (#2 (D.W.extract w')))) (D.W.duplicate w)) | |
| end | |
| fun dist x = W.Cofree (D.W.map k (D.dist (F.map (fn W.Cofree w => w) x))) | |
| and k fc = (F.map #1 fc, F.map (dist o #2) fc) | |
| end |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Library | |
| structure Test | |
| is | |
| $/basis.cm | |
| $/smlnj-lib.cm | |
| recursion-schemes.sml | |
| test.sml |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| structure Test = | |
| struct | |
| structure TreeF = | |
| struct | |
| datatype 'a t = | |
| Leaf of int | |
| | Bin of 'a * 'a | |
| fun map _ (Leaf n) = Leaf n | |
| | map f (Bin (a, b)) = Bin (f a, f b) | |
| fun toString _ _ = "treef" | |
| (* XXX: This commented code causes the crash! *) | |
| (* fun toString _ (Leaf n) = String.concat ["Leaf ", Int.toString n] *) | |
| (* | toString tos (Bin (a, b)) = String.concat ["Bin (", tos a, ", ", tos b, ")"] *) | |
| end | |
| structure Tree = | |
| struct | |
| datatype t = | |
| Leaf of int | |
| | Bin of t * t | |
| type 'a base = 'a TreeF.t | |
| fun embed (TreeF.Leaf n) = Leaf n | |
| | embed (TreeF.Bin (a, b)) = Bin (a, b) | |
| fun project (Leaf n) = TreeF.Leaf n | |
| | project (Bin (a, b)) = TreeF.Bin (a, b) | |
| end | |
| structure Dist = HistomorphismDist(CatamorphismDist(TreeF)) | |
| structure Histo = GeneralizedCatamorphism( | |
| struct | |
| structure T = Tree | |
| structure D = Dist | |
| end) | |
| fun cofreeToString tos (Dist.W.Cofree (a, f)) = | |
| String.concat [ | |
| tos a, " :< (", TreeF.toString (cofreeToString tos) f, ")" | |
| ] | |
| val t = Tree.Bin ( | |
| Tree.Bin (Tree.Leaf 1, Tree.Leaf 2), | |
| Tree.Bin (Tree.Leaf 3, Tree.Leaf 4)) | |
| fun alg (TreeF.Leaf n) = n | |
| | alg (TreeF.Bin (a as Dist.W.Cofree (n, _), b as Dist.W.Cofree (m, _))) = ( | |
| List.app TextIO.print [ | |
| "a = ", | |
| cofreeToString Int.toString a, | |
| "\nb = ", | |
| cofreeToString Int.toString b, | |
| "\n\n" | |
| ]; | |
| n + m) | |
| val result = Histo.cata alg t | |
| val () = List.app TextIO.print ["result = ", Int.toString result, "\n"] | |
| end |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment