Merge pull request #6 from antitypical/distributive-algebra

🔥 dependency on fused-effects

Author: robrix

fused-syntax.cabal

@@ -32,11 +32,16 @@ common common
     -Wno-unsafe
   if (impl(ghc >= 8.8))
     ghc-options: -Wno-missing-deriving-strategies
+  if (impl(ghc >= 8.10))
+    ghc-options:
+      -Wno-missing-safe-haskell-mode
+      -Wno-prepositive-qualified-module
 
 library
   import: common
   hs-source-dirs: src
   exposed-modules:
+    Syntax.Algebra
     Syntax.Fin
     Syntax.Fix
     Syntax.Foldable
@@ -55,6 +60,5 @@ library
   other-modules:
     Example.Lam
   build-depends:
-      base           >= 4.12 && < 4.14
-    , fused-effects ^>= 1
+      base           >= 4.12 && < 5
     , transformers  ^>= 0.5.6

src/Example/Lam.hs

@@ -1,13 +1,14 @@
-{-# LANGUAGE ConstraintKinds, DeriveGeneric, DeriveTraversable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds, DeriveGeneric, DeriveTraversable, FlexibleContexts, MultiParamTypeClasses, QuantifiedConstraints, StandaloneDeriving, TypeFamilies #-}
 module Example.Lam
 ( Lam(..)
 , lam
 , ($$)
 ) where
 
-import Control.Algebra
 import GHC.Generics (Generic1)
+import Syntax.Algebra
 import Syntax.Foldable
+import Syntax.Functor
 import Syntax.Module
 import Syntax.Scope
 import Syntax.Traversable

src/Syntax/Algebra.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Syntax.Algebra
+( Algebra(..)
+, Has
+, send
+) where
+
+import Syntax.Functor
+import Syntax.Sum
+
+class (HFunctor sig, Applicative t) => Algebra sig t | t -> sig where
+  alg :: sig t a -> t a
+
+
+-- | @m@ is a carrier for @sig@ containing @eff@.
+--
+-- Note that if @eff@ is a sum, it will be decomposed into multiple 'Member' constraints. While this technically allows one to combine multiple unrelated effects into a single 'Has' constraint, doing so has two significant drawbacks:
+--
+-- 1. Due to [a problem with recursive type families](https://gitlab.haskell.org/ghc/ghc/issues/8095), this can lead to significantly slower compiles.
+--
+-- 2. It defeats @ghc@’s warnings for redundant constraints, and thus can lead to a proliferation of redundant constraints as code is changed.
+type Has eff sig m = (Members eff sig, Algebra sig m)
+
+-- | Construct a request for an effect to be interpreted by some handler later on.
+send :: (Member eff sig, Algebra sig m) => eff m a -> m a
+send = alg . inj
+{-# INLINE send #-}

src/Syntax/Fix.hs

@@ -25,9 +25,7 @@ deriving instance (forall g . Foldable    g => Foldable    (sig g)
 
 
 hoistFix
-  :: ( HFunctor sig
-     , forall g . Functor g => Functor (sig g)
-     )
+  :: HFunctor sig
   => (forall m x . sig m x -> sig' m x)
   -> (Fix sig a -> Fix sig' a)
 hoistFix f = cata (Fix . f)
@@ -39,9 +37,7 @@ prjFix = maybe empty pure . prj . unFix
 
 cata
   :: forall sig m a
-  .  ( HFunctor sig
-     , forall g . Functor g => Functor (sig g)
-     )
+  .  HFunctor sig
   => (forall x . sig m x -> m x)
   -> Fix sig a
   -> m a

src/Syntax/Functor.hs

@@ -1,6 +1,66 @@
-{-# LANGUAGE DefaultSignatures, QuantifiedConstraints, RankNTypes, TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
 module Syntax.Functor
 ( HFunctor(..)
+, GHFunctor
 ) where
 
-import Control.Effect.Class (HFunctor(..))
+import qualified Syntax.Sum as Sum
+import           GHC.Generics
+
+class (forall f . Functor f => Functor (h f)) => HFunctor h where
+  hmap :: Functor f => (forall x . f x -> g x) -> (h f a -> h g a)
+  default hmap
+    :: (Functor f, Generic1 (h f), Generic1 (h g), GHFunctor f g (Rep1 (h f)) (Rep1 (h g)))
+    => (forall a . f a -> g a)
+    -> (h f a -> h g a)
+  hmap f = to1 . ghmap f . from1
+
+instance (HFunctor l, HFunctor r) => HFunctor (l Sum.:+: r) where
+  hmap f = \case
+    Sum.L l -> Sum.L (hmap f l)
+    Sum.R r -> Sum.R (hmap f r)
+  {-# INLINE hmap #-}
+
+
+class GHFunctor g g' rep rep' where
+  ghmap :: Functor g => (forall x . g x -> g' x) -> rep a -> rep' a
+
+instance GHFunctor g g' V1 V1 where
+  ghmap _ = \case {}
+
+instance GHFunctor g g' U1 U1 where
+  ghmap _ = id
+
+instance GHFunctor g g' (K1 R r) (K1 R r) where
+  ghmap _ = id
+
+instance GHFunctor g g' Par1 Par1 where
+  ghmap _ = id
+
+instance (GHFunctor g g' l l', GHFunctor g g' r r') => GHFunctor g g' (l :*: r) (l' :*: r') where
+  ghmap f (l :*: r) = ghmap f l :*: ghmap f r
+
+instance (Traversable f, GHFunctor g g' sig sig') => GHFunctor g g' (f :.: sig) (f :.: sig') where
+  ghmap f = Comp1 . fmap (ghmap f) . unComp1
+
+instance (GHFunctor g g' l l', GHFunctor g g' r r') => GHFunctor g g' (l :+: r) (l' :+: r') where
+  ghmap f = \case
+    L1 l -> L1 $ ghmap f l
+    R1 r -> R1 $ ghmap f r
+
+instance GHFunctor g g' f f' => GHFunctor g g' (M1 i c f) (M1 i c f') where
+  ghmap f = M1 . ghmap f . unM1
+
+instance GHFunctor g g' (Rec1 g) (Rec1 g') where
+  ghmap f = Rec1 . f . unRec1
+
+instance HFunctor sig => GHFunctor g g' (Rec1 (sig g)) (Rec1 (sig g')) where
+  ghmap f = Rec1 . hmap f . unRec1

src/Syntax/Module.hs

@@ -75,7 +75,10 @@ joinr :: (RightModule f, Monad m) => f m (m a) -> f m a
 joinr = (>>=* id)
 
 
-instance (RightModule f, RightModule g) => RightModule (f Sum.:+: g)
+instance (RightModule f, RightModule g) => RightModule (f Sum.:+: g) where
+  s >>=* f = case s of
+    Sum.L l -> Sum.L (l >>=* f)
+    Sum.R r -> Sum.R (r >>=* f)
 
 
 class (HFunctor f, forall g . Functor g => Functor (f g)) => LeftModule f where

src/Syntax/Sum.hs

@@ -1,14 +1,24 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds, TypeOperators #-}
+{-# LANGUAGE ConstraintKinds, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds, TypeFamilies, TypeOperators #-}
 module Syntax.Sum
 ( -- * Sum syntax
   (:+:)(..)
 , unSum
   -- * Membership
 , Inject(..)
 , Project(..)
+, Member
+, Members
 ) where
 
-import Control.Effect.Sum ((:+:)(..))
+import Data.Kind (Constraint)
+import GHC.Generics (Generic1)
+
+data (f :+: g) (m :: * -> *) k
+  = L (f m k)
+  | R (g m k)
+  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
+
+infixr 4 :+:
 
 unSum :: (f t a -> b) -> (g t a -> b) -> (f :+: g) t a -> b
 unSum f _ (L l) = f l
@@ -65,3 +75,15 @@ instance {-# OVERLAPPABLE #-}
       => Project t (l :+: r) where
   prj (R r) = prj r
   prj _     = Nothing
+
+
+type Member sub sup = (Inject sub sup, Project sub sup)
+
+-- | Decompose sums on the left into multiple 'Member' constraints.
+--
+-- Note that while this, and by extension 'Control.Algebra.Has', can be used to group together multiple membership checks into a single (composite) constraint, large signatures on the left can slow compiles down due to [a problem with recursive type families](https://gitlab.haskell.org/ghc/ghc/issues/8095).
+--
+-- @since 1.0.0.0
+type family Members sub sup :: Constraint where
+  Members (l :+: r) u = (Members l u, Members r u)
+  Members t         u = Member t u

src/Syntax/Term.hs

@@ -12,9 +12,9 @@ module Syntax.Term
 , foldTerm
 ) where
 
-import Control.Algebra (Algebra(..))
 import Control.Applicative (Alternative(..))
 import Control.Monad ((<=<), ap)
+import Syntax.Algebra (Algebra(..))
 import Syntax.Fin
 import Syntax.Functor
 import Syntax.Module
@@ -64,9 +64,7 @@ instance RightModule sig
 
 
 hoistTerm
-  :: ( HFunctor sig
-     , forall g . Functor g => Functor (sig g)
-     )
+  :: HFunctor sig
   => (forall m x . sig m x -> sig' m x)
   -> (Term sig a -> Term sig' a)
 hoistTerm f = cata Var (Alg . f)
@@ -80,17 +78,15 @@ prjTerm :: (Alternative m, Project sub sig) => Term sig a -> m (sub (Term sig) a
 prjTerm = maybe empty pure . (prj <=< unTerm)
 
 
-iter :: (Algebra sig m, forall f . Functor f => Functor (sig f)) => Term sig a -> m a
+iter :: Algebra sig m => Term sig a -> m a
 iter = \case
   Var a -> pure a
   Alg t -> alg (hmap iter t)
 
 
 cata
   :: forall sig m a
-  .  ( HFunctor sig
-     , forall g . Functor g => Functor (sig g)
-     )
+  .  HFunctor sig
   => (forall x . x -> m x)
   -> (forall x . sig m x -> m x)
   -> (Term sig a -> m a)

src/Syntax/Trans/Scope.hs

@@ -41,7 +41,7 @@ unScopeT (ScopeT s) = s
 instance HFoldable t => HFoldable (ScopeT a t) where
   hfoldMap f = getAlt . foldMap (Alt . f) <=< hfoldMap f . unScopeT
 
-instance (HFunctor t, forall g . Functor g => Functor (t g)) => HFunctor (ScopeT a t) where
+instance HFunctor t => HFunctor (ScopeT a t) where
   hmap f = ScopeT . hmap f . fmap (fmap f) . unScopeT
 
 instance HTraversable t => HTraversable (ScopeT a t) where
@@ -67,7 +67,7 @@ instance (Monad (t f), MonadTrans t, Monad f) => Monad (ScopeT a t f) where
 instance MonadTrans f => MonadTrans (ScopeT a f) where
   lift = ScopeT . lift . pure . F
 
-instance (HFunctor t, forall g . Functor g => Functor (t g)) => RightModule (ScopeT b t) where
+instance HFunctor t => RightModule (ScopeT b t) where
   ScopeT s >>=* k = ScopeT (fmap (>>= k) <$> s)
 
 

src/Syntax/Traversable.hs

@@ -11,7 +11,6 @@ import qualified Syntax.Sum as Sum
 
 class ( HFoldable sig
       , HFunctor sig
-      , forall g . Functor  g    => Functor     (sig g)
       , forall g . Traversable g => Traversable (sig g)
       )
    => HTraversable sig where
@@ -25,7 +24,10 @@ class ( HFoldable sig
     -> (sig g a -> f (sig h a))
   htraverse f = fmap to1 . ghtraverse f . from1
 
-instance (HTraversable l, HTraversable r) => HTraversable (l Sum.:+: r)
+instance (HTraversable l, HTraversable r) => HTraversable (l Sum.:+: r) where
+  htraverse f = \case
+    Sum.L l -> Sum.L <$> htraverse f l
+    Sum.R r -> Sum.R <$> htraverse f r
 
 
 class GHTraversable g g' rep rep' where