etc

minipat/minipat.cabal

@@ -71,7 +71,7 @@ library
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds
   build-depends:
       base >=4.12 && <5
-    , bowtie ==0.2.*
+    , bowtie ==0.3.*
     , containers ==0.6.*
     , heaps ==0.4.*
     , looksee ==0.5.*
@@ -123,7 +123,7 @@ test-suite minipat-test
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.12 && <5
-    , bowtie ==0.2.*
+    , bowtie ==0.3.*
     , containers ==0.6.*
     , daytripper ==0.3.*
     , heaps ==0.4.*

minipat/package.yaml

@@ -15,7 +15,7 @@ defaults:
 
 dependencies:
 - base >= 4.12 && < 5
-- bowtie >= 0.2 && < 0.3
+- bowtie >= 0.3 && < 0.4
 - containers >= 0.6 && < 0.7
 - heaps >= 0.4 && < 0.5
 - looksee >= 0.5 && < 0.6

minipat/src/Minipat/Interp.hs

@@ -7,6 +7,7 @@ module Minipat.Interp
   )
 where
 
+import Bowtie.Rewrite (AnnoErr, Rw, embedRw, throwRw)
 import Control.Exception (Exception)
 import Data.Ratio ((%))
 import Minipat.Ast
@@ -26,7 +27,7 @@ import Minipat.Ast
   , SpeedDir (..)
   , factorValue
   )
-import Minipat.Rewrite (AnnoErr, Rw, patCataRw, runPatRw, throwRw)
+import Minipat.Rewrite (patRw)
 
 -- | An error interpreting a 'Pat' as a 'Stream'
 data InterpErr
@@ -59,7 +60,7 @@ lookInterp = \case
   PatMod (Mod (el, w) md) -> do
     case md of
       ModTypeSpeed (Speed dir spat) -> do
-        spat' <- subInterp spat
+        spat' <- embedRw (interpPat spat)
         let f = case dir of
               SpeedDirFast -> patFast
               SpeedDirSlow -> patSlow
@@ -84,8 +85,5 @@ lookInterp = \case
         pure (el', w')
   PatPoly (Poly _ _) -> error "TODO"
 
-subInterp :: (Pattern f) => Pat b a -> Rw b InterpErr (f a)
-subInterp = fmap fst . patCataRw lookInterp
-
 interpPat :: (Pattern f) => Pat b a -> Either (AnnoErr b InterpErr) (f a)
-interpPat = runPatRw subInterp
+interpPat = fmap fst . patRw lookInterp

minipat/src/Minipat/Norm.hs

@@ -5,6 +5,7 @@ module Minipat.Norm
 where
 
 import Bowtie (pattern JotP)
+import Bowtie.Rewrite (Rw, peeksRw, unwrapAnnoErr, wrapRw)
 import Data.Sequence (Seq (..))
 import Data.Sequence.NonEmpty (NESeq (..))
 import Data.Sequence.NonEmpty qualified as NESeq
@@ -21,7 +22,7 @@ import Minipat.Ast
   , Short (..)
   , UnPat
   )
-import Minipat.Rewrite (Rw, patNatRw, peeksRw, runPatRw, unwrapAnnoErr, wrapRw)
+import Minipat.Rewrite (patNatRw)
 
 foldNorm :: (b -> b -> b) -> Seq (UnPat b a) -> Seq (UnPat b a)
 foldNorm f = goFirst
@@ -66,7 +67,7 @@ subNorm f x = case x of
 -- Someday we might want to expose this variant, which supports
 -- combining annotations any way we choose
 normPat' :: (b -> b -> b) -> Pat b a -> Pat b a
-normPat' f = unwrapAnnoErr . runPatRw (patNatRw (subNorm f))
+normPat' f = unwrapAnnoErr . patNatRw (subNorm f)
 
 -- | Normalize the given pattern
 normPat :: (Semigroup b) => Pat b a -> Pat b a

minipat/src/Minipat/Parser.hs

@@ -16,7 +16,7 @@ module Minipat.Parser
   )
 where
 
-import Bowtie (Anno (..), Jot, pattern JotP)
+import Bowtie (Anno (..), Jot (..), annoJot, pattern JotP)
 import Control.Exception (Exception)
 import Control.Monad (guard, when)
 import Control.Monad.Fix (fix)
@@ -29,10 +29,6 @@ import Looksee qualified as L
 import Minipat.Ast
 import Minipat.Print (Brace (..), braceCloseChar, braceOpenChar)
 
--- Should be in Bowtie
-annoJot :: Anno b (g a (Jot g b a)) -> Jot g b a
-annoJot (Anno b x) = JotP b x
-
 -- * The basics
 
 -- | Error when parsing

minipat/src/Minipat/Rewrite.hs

@@ -3,111 +3,29 @@
 -- | Utilities for rewriting patterns
 module Minipat.Rewrite where
 
-import Bowtie (Jot, pattern JotP)
-import Control.Exception (Exception)
+import Bowtie (pattern JotP)
+import Bowtie.Rewrite (AnnoErr, Rw, RwT, embedRwT, jotRw, jotRwT, pushRw, runRwT)
 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)
 import Minipat.Ast (Mod (..), ModType (..), Pat (..), PatF (..), Poly (..), Speed (..), UnPat)
 
--- * General rewriting (can go in Bowtie)
+patRw :: (PatF b a z -> Rw b e z) -> Pat b a -> Either (AnnoErr b e) z
+patRw f = jotRw f . unPat
 
-data AnnoErr k e = AnnoErr
-  { annoErrKey :: !k
-  , annoErrVal :: !e
-  }
-  deriving stock (Eq, Ord, Show)
+patRwT :: (Monad m) => (PatF b a (RwT b e m z) -> RwT b e m z) -> Pat b a -> m (Either (AnnoErr b e) z)
+patRwT f = jotRwT f . unPat
 
-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
-
-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
-
-jotCataRw :: (Bitraversable g) => (g a z -> Rw k e z) -> Jot g k a -> Rw k e z
-jotCataRw f = jotCataRwT (bitraverse pure id >=> f)
-
-jotCataRwT :: (Monad m, Bitraversable g) => (g a (RwT k e m z) -> RwT k e m z) -> Jot g k a -> RwT k e m z
-jotCataRwT f = goJ
- where
-  goJ (JotP b g) = pushRw b (goG g)
-  goG g = f (fmap goJ g)
-
--- * Pattern rewriting
-
-patCataRw :: (PatF b a z -> Rw b e z) -> Pat b a -> Rw b e z
-patCataRw f = jotCataRw f . unPat
-
-patCataRwT :: (Monad m) => (PatF b a (RwT b e m z) -> RwT b e m z) -> Pat b a -> RwT b e m z
-patCataRwT f = jotCataRwT f . unPat
-
-patNatRw :: (forall x. PatF b x (UnPat b x) -> Rw b e (UnPat b x)) -> Pat b a -> Rw b e (Pat b a)
-patNatRw f = patNatRwT (bitraverse pure id >=> f)
+patNatRw :: (forall x. PatF b x (UnPat b x) -> Rw b e (UnPat b x)) -> Pat b a -> Either (AnnoErr b e) (Pat b a)
+patNatRw f = runIdentity . patNatRwT (bitraverse pure id >=> f)
 
+-- TODO can use jotRwT (goG pf >>= f) or something?
 patNatRwT
-  :: (Monad m) => (forall x. PatF b x (RwT b e m (UnPat b x)) -> RwT b e m (UnPat b x)) -> Pat b a -> RwT b e m (Pat b a)
-patNatRwT f = goP
+  :: (Monad m)
+  => (forall x. PatF b x (RwT b e m (UnPat b x)) -> RwT b e m (UnPat b x))
+  -> Pat b a
+  -> m (Either (AnnoErr b e) (Pat b a))
+patNatRwT f p0@(Pat (JotP b0 _)) = runRwT (goP p0) b0
  where
   goP = fmap Pat . goJ . unPat
   goJ (JotP b pf) = pushRw b (goG pf >>= f)
@@ -124,14 +42,9 @@ patNatRwT f = goP
     ModTypeSpeed s -> fmap ModTypeSpeed (goS s)
     ModTypeElongate e -> pure (ModTypeElongate e)
     ModTypeReplicate r -> pure (ModTypeReplicate r)
-  goS (Speed d p) = fmap (Speed d) (patNatRwT f p)
-
-runPatRw :: (Pat b a -> Rw b e z) -> Pat b a -> Either (AnnoErr b e) z
-runPatRw g p@(Pat (JotP b _)) = runRw (g p) b
-
-runPatRwT :: (Pat b a -> RwT b e m z) -> Pat b a -> m (Either (AnnoErr b e) z)
-runPatRwT g p@(Pat (JotP b _)) = runRwT (g p) b
+  goS (Speed d p) = fmap (Speed d) (embedRwT (patNatRwT f p))
 
+-- TODO just make Bifunctor instance
 patMapInfo :: (b -> c) -> Pat b a -> Pat c a
 patMapInfo f = goP
  where

stack.yaml

@@ -8,7 +8,7 @@ packages:
 - minipat-dirt
 
 extra-deps:
-- bowtie-0.2.0
+- bowtie-0.3.1
 - dahdit-0.5.1
 - dahdit-network-0.5.2
 - dahdit-midi-0.5.5

stack.yaml.lock

@@ -5,12 +5,12 @@
 
 packages:
 - completed:
-    hackage: bowtie-0.2.0@sha256:1fea0ef4521f8c77544aa885f47d6999acf75db8f0b093fe639d24004a1fbe6f,1771
+    hackage: bowtie-0.3.1@sha256:75386b80c198e948c36e3647df9619f48fcaaf3cd38edafa66bc4a0614fbe613,1848
     pantry-tree:
-      sha256: e72e660bb9ba5ec65ca5572f49fe4467a4a8fba7319e566131c373daaf9dc0af
-      size: 159
+      sha256: 0164d98ecc676e9b95dddc53dc175888213c8c957db114d3748db755ecca9658
+      size: 221
   original:
-    hackage: bowtie-0.2.0
+    hackage: bowtie-0.3.1
 - completed:
     hackage: dahdit-0.5.1@sha256:f583794914a2c775f3e59fe4ef1d39c5ab827ff27894da32f7ae0de4ea9f15b1,3704
     pantry-tree: