packages feed

bowtie 0.2.0 → 0.3.0

raw patch · 3 files changed

+108/−8 lines, 3 filesdep +nonempty-containers

Dependencies added: nonempty-containers

Files

bowtie.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           bowtie-version:        0.2.0+version:        0.3.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@@ -27,6 +27,7 @@ library   exposed-modules:       Bowtie+      Bowtie.Rewrite   other-modules:       Paths_bowtie   hs-source-dirs:@@ -49,6 +50,7 @@       LambdaCase       KindSignatures       MultiParamTypeClasses+      PatternSynonyms       Rank2Types       ScopedTypeVariables       StandaloneDeriving@@ -62,6 +64,7 @@     , bifunctors ==5.6.*     , comonad ==5.0.*     , mtl ==2.3.*+    , nonempty-containers ==0.3.*     , prettyprinter ==1.7.*     , recursion-schemes ==5.2.*     , semigroupoids ==6.0.*
src/Bowtie.hs view
@@ -52,6 +52,7 @@   , pattern JotP   , mkJot   , unMkJot+  , annoJot   , transJot   , jotKey   , jotVal@@ -64,6 +65,7 @@ where  import Control.Comonad (Comonad (..))+import Control.Exception (Exception) import Control.Monad ((>=>)) import Control.Monad.Reader (Reader, ReaderT (..), runReader) import Data.Bifoldable (Bifoldable (..))@@ -74,6 +76,7 @@ import Data.Functor.Identity (Identity (..)) import Data.Kind (Type) import Data.String (IsString (..))+import Data.Typeable (Typeable) import Prettyprinter (Pretty (..))  -- | 'Base' for Bifunctors@@ -183,12 +186,9 @@  where   go = Knot . nat . second go . unKnot --- | An "annotation" - a strict key associated with a lazy value.--- Hopefully this is a bit better behaved than just a tuple, being--- strict in the head and lazy in the tail when this is tied into a--- recursive structure through the second position.+-- | An "annotation" with associated value. type Anno :: Type -> Type -> Type-data Anno k v = Anno {annoKey :: !k, annoVal :: v}+data Anno k v = Anno {annoKey :: !k, annoVal :: !v}   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)  instance Bifunctor Anno where@@ -218,6 +218,8 @@ instance (Monoid k, IsString v) => IsString (Anno k v) where   fromString = Anno mempty . fromString +instance (Show k, Typeable k, Exception v) => Exception (Anno k v)+ -- | 'unit' from 'Adjunction' annoUnit :: v -> Reader k (Anno k v) annoUnit v = ReaderT (Identity . (`Anno` v))@@ -430,6 +432,10 @@ unMkJot :: (Corecursive1 t, Base1 t ~ g) => Jot g k a -> t a unMkJot (JotP _ v) = embed1 (fmap unMkJot v) +-- | Quick conversion from annotated functor.+annoJot :: Anno b (g a (Jot g b a)) -> Jot g b a+annoJot = Jot . JotF+ -- | Transform the base functor. transJot :: (Bifunctor g) => (forall x. g a x -> h a x) -> Jot g k a -> Jot h k a transJot nat = go@@ -449,10 +455,10 @@   go (JotP k v) = runReader (f (fmap go v)) k  -- | 'cataM' but nicer-jotCataM :: (Monad m, Bitraversable g) => (g a x -> ReaderT k m x) -> Jot g k a -> m x+jotCataM :: (Bifunctor g) => (g a (m x) -> ReaderT k m x) -> Jot g k a -> m x jotCataM f = go  where-  go (JotP k v) = bitraverse pure go v >>= \x -> runReaderT (f x) k+  go (JotP k v) = runReaderT (f (fmap go v)) k  -- | Peek at the top value like 'annoRight' jotRight :: (g a (Jot g k a) -> Reader k x) -> Jot g k a -> x
+ src/Bowtie/Rewrite.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE UndecidableInstances #-}++module Bowtie.Rewrite where++import Bowtie (Jot, pattern JotP)+import Control.Exception (Exception)+import Control.Monad ((>=>))+import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Identity (Identity (..))+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Control.Monad.State (MonadState (..))+import Control.Monad.Trans (MonadTrans (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Sequence.NonEmpty (NESeq)+import Data.Sequence.NonEmpty qualified as NESeq+import Data.Typeable (Typeable)+import Data.Void (Void, absurd)++data AnnoErr k e = AnnoErr+  { annoErrKey :: !k+  , annoErrVal :: !e+  }+  deriving stock (Eq, Ord, Show)++instance+  (Show k, Typeable k, Show e, Typeable e)+  => Exception (AnnoErr k e)++unwrapAnnoErr :: Either (AnnoErr k Void) a -> a+unwrapAnnoErr = either (absurd . annoErrVal) id++newtype RwT k e m a = RwT {unRwT :: ReaderT (NESeq k) (ExceptT (AnnoErr k e) m) a}+  deriving newtype (Functor, Applicative, Monad)++type Rw k e = RwT k e Identity++instance MonadTrans (RwT k e) where+  lift = RwT . lift . lift++runRwT :: RwT k e m a -> k -> m (Either (AnnoErr k e) a)+runRwT m = runExceptT . runReaderT (unRwT m) . NESeq.singleton++runRw :: Rw k e a -> k -> Either (AnnoErr k e) a+runRw m = runIdentity . runRwT m++embedRwT :: m (Either (AnnoErr k e) a) -> RwT k e m a+embedRwT n = RwT (ReaderT (const (ExceptT n)))++pushRw :: (Monad m) => k -> RwT k e m a -> RwT k e m a+pushRw b m = RwT (local (NESeq.|> b) (unRwT m))++peekRw :: (Monad m) => RwT k e m k+peekRw = RwT (asks NESeq.last)++peeksRw :: (Monad m) => (k -> a) -> RwT k e m a+peeksRw f = RwT (asks (f . NESeq.last))++askRw :: (Monad m) => RwT k e m (NESeq k)+askRw = RwT ask++asksRw :: (Monad m) => (NESeq k -> a) -> RwT k e m a+asksRw f = RwT (asks f)++throwRw :: (Monad m) => e -> RwT k e m a+throwRw e = RwT (asks NESeq.last >>= \b -> throwError (AnnoErr b e))++instance (MonadReader r m) => MonadReader r (RwT k e m) where+  ask = lift ask+  reader f = lift (reader f)+  local f m = RwT $ do+    bs <- ask+    ea <- lift (lift (local f (runExceptT (runReaderT (unRwT m) bs))))+    either throwError pure ea++instance (MonadState s m) => MonadState s (RwT k e m) where+  get = lift get+  put = lift . put+  state f = lift (state f)++instance (MonadIO m) => MonadIO (RwT k e m) where+  liftIO = lift . liftIO++wrapRw :: g a (Jot g k a) -> Rw k e (Jot g k a)+wrapRw = peeksRw . flip JotP++jotRw :: (Bitraversable g) => (g a z -> Rw k e z) -> Jot g k a -> Either (AnnoErr k e) z+jotRw f = runIdentity . jotRwT (bitraverse pure id >=> f)++jotRwT :: (Monad m, Bitraversable g) => (g a (RwT k e m z) -> RwT k e m z) -> Jot g k a -> m (Either (AnnoErr k e) z)+jotRwT f j0@(JotP b0 _) = runRwT (go j0) b0 where go (JotP b g) = pushRw b (f (fmap go g))