bowtie 0.4.0 → 0.5.0

raw patch · 3 files changed

+210/−2 lines, 3 files

Files

bowtie.cabal +3/−2
src/Bowtie/Free.hs +196/−0
src/Bowtie/Memo.hs +11/−0

bowtie.cabal view

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           bowtie-version:        0.4.0+version:        0.5.0 synopsis:       Tying knots in polynomial functors description:    Please see the README on GitHub at <https://github.com/ejconlon/bowtie#readme> homepage:       https://github.com/ejconlon/bowtie#readme@@ -31,6 +31,7 @@       Bowtie.Attr       Bowtie.Fix       Bowtie.Foldable+      Bowtie.Free       Bowtie.Jot       Bowtie.Knot       Bowtie.Memo

+ src/Bowtie/Free.hs view

@@ -0,0 +1,196 @@+{-# LANGUAGE UndecidableInstances #-}++-- | We redefine Free here because we prefer undeciable instances+-- to having to derive 'Eq1' and so on.+-- See https://hackage.haskell.org/package/free-5.1.7/docs/Control-Monad-Trans-Free.html+module Bowtie.Free+  ( FreeF (..)+  , Free (..)+  , pattern FreeEmbed+  , pattern FreePure+  , substFree+  , liftFree+  , iterFree+  , iterFreeM+  , FreeT (..)+  , liftFreeT+  , iterFreeT+  , hoistFreeT+  , transFreeT+  , joinFreeT+  )+where++import Control.Monad (ap)+import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))+import GHC.Generics (Generic)++-- | The recursive layer of a free functor+data FreeF f a r+  = FreePureF !a+  | FreeEmbedF !(f r)+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)++instance (Functor f) => Bifunctor (FreeF f) where+  bimap f g = \case+    FreePureF a -> FreePureF (f a)+    FreeEmbedF fr -> FreeEmbedF (fmap g fr)++instance (Foldable f) => Bifoldable (FreeF f) where+  bifoldr f g z = \case+    FreePureF a -> f a z+    FreeEmbedF fr -> foldr g z fr++instance (Traversable f) => Bitraversable (FreeF f) where+  bitraverse f g = \case+    FreePureF a -> fmap FreePureF (f a)+    FreeEmbedF fr -> fmap FreeEmbedF (traverse g fr)++-- | The free functor. Use patterns 'FreePure' and 'FreeEmbed' to match and construct.+newtype Free f a = Free {unFree :: FreeF f a (Free f a)}++pattern FreePure :: a -> Free f a+pattern FreePure a = Free (FreePureF a)++pattern FreeEmbed :: f (Free f a) -> Free f a+pattern FreeEmbed fr = Free (FreeEmbedF fr)++{-# COMPLETE FreePure, FreeEmbed #-}++deriving newtype instance (Eq (f (Free f a)), Eq a) => Eq (Free f a)++deriving newtype instance (Ord (f (Free f a)), Ord a) => Ord (Free f a)++deriving stock instance (Show (f (Free f a)), Show a) => Show (Free f a)++instance (Functor f) => Functor (Free f) where+  fmap f = go+   where+    go = Free . bimap f go . unFree++instance (Functor f) => Applicative (Free f) where+  pure = Free . FreePureF+  (<*>) = ap++instance (Functor f) => Monad (Free f) where+  return = pure+  Free m >>= f = case m of+    FreePureF a -> f a+    FreeEmbedF g -> Free (FreeEmbedF (fmap (>>= f) g))++instance (Foldable f) => Foldable (Free f) where+  foldr f z0 x0 = go x0 z0+   where+    go x z = bifoldr f go z (unFree x)++instance (Traversable f) => Traversable (Free f) where+  traverse f = go+   where+    go = fmap Free . bitraverse f go . unFree++type instance Base (Free f a) = (FreeF f a)++instance (Functor f) => Recursive (Free f a) where+  project = unFree++instance (Functor f) => Corecursive (Free f a) where+  embed = Free++-- | Fills all the holes in the free functor+substFree :: (Corecursive t, f ~ Base t) => (a -> t) -> Free f a -> t+substFree s = go+ where+  go = \case+    FreePure a -> s a+    FreeEmbed fr -> embed (fmap go fr)++-- | A version of lift that can be used with just a Functor for f+liftFree :: (Functor f) => f a -> Free f a+liftFree = FreeEmbed . fmap FreePure++-- | Tear down a free monad using iteration+iterFree :: (Functor f) => (f a -> a) -> Free f a -> a+iterFree f = go+ where+  go (Free x) =+    case x of+      FreePureF a -> a+      FreeEmbedF z -> f (fmap go z)++-- | Like iterFree for monadic values+iterFreeM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a+iterFreeM f = go+ where+  go (Free x) =+    case x of+      FreePureF a -> pure a+      FreeEmbedF z -> f (fmap go z)++newtype FreeT f m a = FreeT {unFreeT :: m (FreeF f a (FreeT f m a))}++deriving newtype instance (Eq (m (FreeF f a (FreeT f m a)))) => Eq (FreeT f m a)++deriving newtype instance (Ord (m (FreeF f a (FreeT f m a)))) => Ord (FreeT f m a)++deriving stock instance (Show (m (FreeF f a (FreeT f m a)))) => Show (FreeT f m a)++instance (Functor f, Functor m) => Functor (FreeT f m) where+  fmap f = go+   where+    go = FreeT . fmap (bimap f go) . unFreeT++instance (Functor f, Monad m) => Applicative (FreeT f m) where+  pure = FreeT . pure . FreePureF+  (<*>) = ap++instance (Functor f, Monad m) => Monad (FreeT f m) where+  return = pure+  FreeT mm >>= f =+    FreeT $+      mm >>= \case+        FreePureF a -> unFreeT (f a)+        FreeEmbedF z -> pure (FreeEmbedF (fmap (>>= f) z))++instance (Foldable f, Foldable m) => Foldable (FreeT f m) where+  foldr f z0 x0 = go x0 z0+   where+    go x z = foldr (flip (bifoldr f go)) z (unFreeT x)++instance (Traversable f, Traversable m) => Traversable (FreeT f m) where+  traverse f = go+   where+    go = fmap FreeT . traverse (bitraverse f go) . unFreeT++liftFreeT :: (Functor f, Applicative m) => f a -> FreeT f m a+liftFreeT = FreeT . pure . FreeEmbedF . fmap (FreeT . pure . FreePureF)++iterFreeT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a+iterFreeT f = go+ where+  go (FreeT m) =+    m >>= \case+      FreePureF a -> pure a+      FreeEmbedF z -> f (fmap go z)++hoistFreeT :: (Functor f, Functor m) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b+hoistFreeT g = go+ where+  go (FreeT m) = FreeT $ g $ flip fmap m $ \case+    FreePureF a -> FreePureF a+    FreeEmbedF z -> FreeEmbedF (fmap go z)++transFreeT :: (Functor g, Monad m) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b+transFreeT g = go+ where+  go (FreeT m) = FreeT $ flip fmap m $ \case+    FreePureF a -> FreePureF a+    FreeEmbedF z -> FreeEmbedF (fmap go (g z))++joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a)+joinFreeT x =+  unFreeT x >>= \case+    FreePureF a -> pure (FreePure a)+    FreeEmbedF z -> fmap FreeEmbed (traverse joinFreeT z)

src/Bowtie/Memo.hs view

@@ -19,10 +19,13 @@   , memoRight   , memoRightM   , memoExtend+  , memoFix+  , memoStructEq   ) where  import Bowtie.Anno (Anno (..), annoRight, annoRightM)+import Bowtie.Fix (Fix) import Control.Monad.Reader (Reader, ReaderT (..), runReader) import Data.Functor.Apply (Apply (..)) import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))@@ -153,3 +156,11 @@ -- | Re-annotate top-down memoExtend :: (Functor f) => (Memo f k -> x) -> Memo f k -> Memo f x memoExtend w = go where go m@(MemoP _ v) = MemoP (w m) (fmap go v)++-- | Forget annotations (useful because the type annotation is tricky)+memoFix :: (Functor f) => Memo f k -> Fix f+memoFix = unMkMemo++-- | Structural equality, ignoring annotations+memoStructEq :: (Functor f, Eq (f (Fix f))) => Memo f k -> Memo f k -> Bool+memoStructEq m1 m2 = memoFix m1 == memoFix m2