Initial commit

.gitignore

+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+
+.DS_Store

README.md

+# A sample implementation of reduction trees

flake.lock

+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1694529238,
+        "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "language-c": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1664454938,
+        "narHash": "sha256-GDjXcq0oYNDGSIWO6kkIgF13RMwykDpUyAQAWRYEOUc=",
+        "owner": "kalhauge",
+        "repo": "language-c",
+        "rev": "0b2f7bf94789b09bbf1e7a1ab80b62f99e1e92f7",
+        "type": "github"
+      },
+      "original": {
+        "owner": "kalhauge",
+        "repo": "language-c",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1699065553,
+        "narHash": "sha256-j8UmH8fqXcOgL6WrlMcvV2m2XQ6OzU0IBucyuJ0vnyQ=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "8ab9c53eee434651ce170dee1d9727b974e9a6b6",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "nixpkgs-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "language-c": "language-c",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

+{
+  inputs = {
+    nixpkgs.url = github:nixos/nixpkgs/nixpkgs-unstable;
+    flake-utils.url = github:numtide/flake-utils;
+    language-c = { url = github:kalhauge/language-c; flake = false; };
+  };
+  outputs =
+    { self
+    , nixpkgs
+    , flake-utils
+    , ...
+    }@inputs:
+    let
+      packages = final: p: {
+        "rtree" = p.callCabal2nixWithOptions "rtree" "${self}" "" { };
+        "language-c" =
+          final.haskell.lib.overrideCabal
+            (p.callCabal2nixWithOptions "language-c" inputs.language-c "" { })
+            {
+              doCheck = false;
+            };
+      };
+      overlays = final: prev: {
+        haskellPackages = prev.haskellPackages.extend (p: _: packages final p);
+      };
+    in
+    {
+      overlays.default = overlays;
+    } //
+    flake-utils.lib.eachDefaultSystem
+      (system:
+      let
+        hpkgs = (import nixpkgs {
+          inherit system;
+          overlays = [ overlays ];
+        }).haskellPackages;
+      in
+      rec {
+        packages = {
+          default = hpkgs.rtree;
+          rtree = hpkgs.rtree;
+        };
+        devShells =
+          let
+            buildInputs = with hpkgs; [
+              cabal-install
+              ghcid
+              haskell-language-server
+              hpack
+              fourmolu
+            ];
+            withHoogle = true;
+          in
+          {
+            default = hpkgs.shellFor
+              {
+                name = "rtree-shell";
+                packages = p:
+                  [ p.rtree ];
+                inherit buildInputs withHoogle;
+              };
+          };
+      });
+}

package.yaml

+name: rtree 
+# version: 0.1.0
+# synopsis: synopsis
+# maintainer: maintainer <email>
+# category: categories
+# extra-source-files: []
+
+ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+
+dependencies:
+  - base >= 4.9 && < 5
+  - containers
+  - language-c
+
+library:
+  source-dirs: src
+
+# tests:
+#   template-test:
+#     source-dirs: test/src
+#     main: Main.hs
+#     dependencies:
+#       - template
+#       - hedgehog
+#       - hspec
+#       - hspec-discover
+#       - hspec-expectations-pretty-diff
+#       - hspec-hedgehog

rtree.cabal

+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           rtree
+version:        0.0.0
+build-type:     Simple
+
+library
+  exposed-modules:
+      Control.RTree
+  other-modules:
+      Paths_rtree
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+  build-depends:
+      base >=4.9 && <5
+    , containers
+    , language-c
+  default-language: Haskell2010

src/Control/RTree.hs

+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- |
+--
+-- Module: Control.RTree
+module Control.RTree where
+
+import Control.Monad (MonadPlus (..), ap, liftM2)
+import Data.Functor
+
+-- | The reduction tree, parameterized by a genrative functor 'f'.
+data ReduceT f i
+  = Done i
+  | f (ReduceT f i) :<| ReduceT f i
+
+instance (Functor f) => Functor (ReduceT f) where
+  fmap f = \case
+    Done i -> Done (f i)
+    mi :<| ri -> fmap (fmap f) mi :<| fmap f ri
+
+instance (Functor f) => Applicative (ReduceT f) where
+  pure = Done
+  (<*>) = ap
+
+instance (Functor f) => Monad (ReduceT f) where
+  ma >>= fa = case ma of
+    Done i -> fa i
+    mi :<| ri -> ((>>= fa) <$> mi) :<| (ri >>= fa)
+
+-- | Change the underlying monad using a natural transformation.
+liftR :: (Functor f) => (forall a. f a -> g a) -> ReduceT f i -> ReduceT g i
+liftR nat = \case
+  Done i -> Done i
+  lhs :<| rhs -> nat (liftR nat <$> lhs) :<| liftR nat rhs
+
+-- | Extract the input from the reducer.
+extract :: ReduceT f i -> i
+extract = \case
+  Done i -> i
+  _ :<| rhs -> extract rhs
+
+-- | Reduce an input using a monad.
+reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i
+reduce fn rt = case rt of
+  Done i -> fn i $> i
+  lhs :<| rhs -> do
+    (lhs >>= reduce fn) `mplus` reduce fn rhs
+
+infixr 3 <|
+
+-- Combinators
+(<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i
+f <| b = pure f :<| b
+
+-- | Split the world on a fact. False it does not happen, and True it does happen.
+given :: (Applicative f) => ReduceT f Bool
+given = pure False <| pure True
+
+-- | A reducer is something that takes an inputs and returns a reduction tree.
+type Reducer m i = i -> ReduceT m i
+
+-- | A reducer should extract itself
+-- @
+--  extract . red = id
+-- @
+lawReduceId :: (Eq i) => Reducer m i -> i -> Bool
+lawReduceId red i = extract (red i) == i
+
+rList :: (Applicative m) => Reducer m [a]
+rList = \case
+  [] -> Done []
+  a : as -> rList as <| (a :) <$> rList as
+
+rBinaryList :: (Applicative m) => Reducer m [a]
+rBinaryList = \case
+  [] -> Done []
+  as -> Done [] <| go as
+  where
+    go = \case
+      [] -> error "unexpected"
+      [a] -> Done [a]
+      as -> go l <| liftM2 (<>) (go f) (Done [] <| go l)
+        where
+          (f, l) = splitAt (length as `div` 2) as