Move recursion schemes to separate package

Author: sellout

codebase2/codebase/U/Codebase/Decl.hs

@@ -12,6 +12,7 @@ import U.Core.ABT qualified as ABT
 import U.Core.ABT.Var qualified as ABT
 import Unison.Hash (Hash)
 import Unison.Prelude
+import Unison.Util.Recursion
 
 type ConstructorId = Word64
 
@@ -107,7 +108,7 @@ unhashComponent componentHash refToVar m =
         { declType,
           modifier,
           bound,
-          constructorTypes = ABT.cata alg <$> constructorTypes
+          constructorTypes = cata alg <$> constructorTypes
         }
       where
         rewriteTypeReference :: Reference.Id' (Maybe Hash) -> Either v Reference.Reference
@@ -126,8 +127,8 @@ unhashComponent componentHash refToVar m =
               case Map.lookup (fromMaybe componentHash <$> rid) withGeneratedVars of
                 Nothing -> error "unhashComponent: self-reference not found in component map"
                 Just (v, _, _) -> Left v
-        alg :: () -> ABT.ABT (Type.F' TypeRef) v (HashableType v) -> HashableType v
-        alg () = \case
+        alg :: ABT.Term' (Type.F' TypeRef) v () (HashableType v) -> HashableType v
+        alg (ABT.Term' _ () abt) = case abt of
           ABT.Var v -> ABT.var () v
           ABT.Cycle body -> ABT.cycle () body
           ABT.Abs v body -> ABT.abs () v body

codebase2/codebase/U/Codebase/Term.hs

@@ -16,6 +16,7 @@ import U.Core.ABT qualified as ABT
 import U.Core.ABT.Var qualified as ABT
 import Unison.Hash (Hash)
 import Unison.Prelude
+import Unison.Util.Recursion
 
 type ConstructorId = Word64
 
@@ -281,7 +282,7 @@ unhashComponent componentHash refToVar m =
     assignVar :: Reference.Id -> (trm, extra) -> StateT (Set v) Identity (v, trm, extra)
     assignVar r (trm, extra) = (,trm,extra) <$> ABT.freshenS (refToVar r)
     fillSelfReferences :: Term v -> HashableTerm v
-    fillSelfReferences = (ABT.cata alg)
+    fillSelfReferences = cata alg
       where
         rewriteTermReference :: Reference.Id' (Maybe Hash) -> Either v Reference.Reference
         rewriteTermReference rid@(Reference.Id mayH pos) =
@@ -299,8 +300,8 @@ unhashComponent componentHash refToVar m =
               case Map.lookup (fromMaybe componentHash <$> rid) withGeneratedVars of
                 Nothing -> error "unhashComponent: self-reference not found in component map"
                 Just (v, _, _) -> Left v
-        alg :: () -> ABT.ABT (F v) v (HashableTerm v) -> HashableTerm v
-        alg () = \case
+        alg :: ABT.Term' (F v) v () (HashableTerm v) -> HashableTerm v
+        alg (ABT.Term' _ () abt) = case abt of
           ABT.Var v -> ABT.var () v
           ABT.Cycle body -> ABT.cycle () body
           ABT.Abs v body -> ABT.abs () v body

codebase2/codebase/package.yaml

@@ -11,6 +11,7 @@ dependencies:
   - unison-core
   - unison-hash
   - unison-prelude
+  - unison-util-recursion
 
 library:
   source-dirs: .

codebase2/codebase/unison-codebase.cabal

@@ -69,4 +69,5 @@ library
     , unison-core
     , unison-hash
     , unison-prelude
+    , unison-util-recursion
   default-language: GHC2021

codebase2/core/U/Core/ABT.hs

@@ -10,6 +10,7 @@ import Debug.RecoverRTTI qualified as RTTI
 import U.Core.ABT.Var (Var (freshIn))
 import Unison.Debug qualified as Debug
 import Unison.Prelude
+import Unison.Util.Recursion
 import Prelude hiding (abs, cycle)
 
 data ABT f v r
@@ -24,6 +25,13 @@ data ABT f v r
 data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)}
   deriving (Functor, Foldable, Generic, Traversable)
 
+data Term' f v a x = Term' {freeVars' :: Set v, annotation' :: a, out' :: ABT f v x}
+  deriving (Functor)
+
+instance (Functor f) => Recursive (Term f v a) (Term' f v a) where
+  embed (Term' vs a abt) = Term vs a abt
+  project (Term vs a abt) = Term' vs a abt
+
 instance (Foldable f, Functor f, forall a. (Eq a) => Eq (f a), Var v) => Eq (Term f v a) where
   -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable
   t1 == t2 = go (out t1) (out t2)
@@ -97,24 +105,6 @@ vmapM f (Term _ a out) = case out of
   Cycle r -> cycle a <$> vmapM f r
   Abs v body -> abs a <$> f v <*> vmapM f body
 
-cata ::
-  (Functor f) =>
-  (a -> ABT f v x -> x) ->
-  Term f v a ->
-  x
-cata abtAlg =
-  let go (Term _fvs a out) = abtAlg a (fmap go out)
-   in go
-
-para ::
-  (Functor f) =>
-  (a -> ABT f v (Term f v a, x) -> x) ->
-  Term f v a ->
-  x
-para abtAlg =
-  let go (Term _fvs a out) = abtAlg a (fmap (\x -> (x, go x)) out)
-   in go
-
 transform ::
   (Ord v, Foldable g, Functor g) =>
   (forall a. f a -> g a) ->

codebase2/core/package.yaml

@@ -17,6 +17,7 @@ dependencies:
   - text
   - unison-hash
   - unison-prelude
+  - unison-util-recursion
 
 default-extensions:
   - ApplicativeDo

codebase2/core/unison-core.cabal

@@ -64,4 +64,5 @@ library
     , text
     , unison-hash
     , unison-prelude
+    , unison-util-recursion
   default-language: Haskell2010

contrib/cabal.project

@@ -21,9 +21,10 @@ packages:
   lib/unison-util-base32hex
   lib/unison-util-bytes
   lib/unison-util-cache
+  lib/unison-util-file-embed
+  lib/unison-util-recursion
   lib/unison-util-relation
   lib/unison-util-rope
-  lib/unison-util-file-embed
 
   parser-typechecker
   unison-core

lib/unison-util-recursion/package.yaml

@@ -0,0 +1,46 @@
+name: unison-util-recursion
+github: unisonweb/unison
+copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
+
+ghc-options: -Wall
+
+dependencies:
+  - base
+  - free
+
+library:
+  source-dirs: src
+  when:
+    - condition: false
+      other-modules: Paths_unison_util_recursion
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DeriveAnyClass
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - DerivingVia
+  - DoAndIfThenElse
+  - DuplicateRecordFields
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GeneralizedNewtypeDeriving
+  - ImportQualifiedPost
+  - LambdaCase
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - OverloadedStrings
+  - PatternSynonyms
+  - RankNTypes
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - ViewPatterns

lib/unison-util-recursion/src/Unison/Util/Recursion.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Unison.Util.Recursion
+  ( Algebra,
+    Recursive (..),
+    cataM,
+    para,
+    Fix (..),
+    Cofree' (..),
+  )
+where
+
+import Control.Arrow ((&&&))
+import Control.Comonad.Cofree (Cofree ((:<)))
+import Control.Monad ((<=<))
+
+type Algebra f a = f a -> a
+
+class Recursive t f | t -> f where
+  cata :: (Algebra f a) -> t -> a
+  default cata :: (Functor f) => (f a -> a) -> t -> a
+  cata φ = φ . fmap (cata φ) . project
+  project :: t -> f t
+  default project :: (Functor f) => t -> f t
+  project = cata (fmap embed)
+  embed :: f t -> t
+  {-# MINIMAL embed, (cata | project) #-}
+
+cataM :: (Recursive t f, Traversable f, Monad m) => (f a -> m a) -> t -> m a
+cataM φ = cata $ φ <=< sequenceA
+
+para :: (Recursive t f, Functor f) => (f (t, a) -> a) -> t -> a
+para φ = snd . cata (embed . fmap fst &&& φ)
+
+newtype Fix f = Fix (f (Fix f))
+
+deriving instance (forall a. (Show a) => Show (f a)) => Show (Fix f)
+
+deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (Fix f)
+
+deriving instance (Eq (Fix f), forall a. (Ord a) => Ord (f a)) => Ord (Fix f)
+
+instance (Functor f) => Recursive (Fix f) f where
+  embed = Fix
+  project (Fix f) = f
+
+data Cofree' f a x = a :<< f x
+  deriving (Foldable, Functor, Traversable)
+
+-- |
+--
+--  __NB__: `Cofree` from “free” is lazy, so this instance is technically partial.
+instance (Functor f) => Recursive (Cofree f a) (Cofree' f a) where
+  embed (a :<< fco) = a :< fco
+  project (a :< fco) = a :<< fco