rework

minipat/src/Minipat/Ast.hs

@@ -29,7 +29,6 @@ module Minipat.Ast
   , Poly (..)
   , PatF (..)
   , Pat (..)
-  , PatX
   , UnPat
   , Pattern (..)
   )
@@ -204,13 +203,16 @@ instance Pretty SpeedDir where
     SpeedDirSlow -> "/"
 
 -- | Speed control
-data Speed s = Speed
+data Speed b = Speed
   { speedDir :: !SpeedDir
-  , speedFactor :: !s
+  , speedFactor :: !(Pat b Factor)
   }
-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+  deriving stock (Eq, Ord, Show)
+
+-- instance Foldable Speed where
+--   foldr f z (Speed x y) = Speed x (bifoldr f y)
 
-instance (Pretty s) => Pretty (Speed s) where
+instance Pretty (Speed b) where
   pretty (Speed dir facs) = P.hcat [pretty dir, pretty facs]
 
 -- | Euclidean sequences
@@ -253,15 +255,15 @@ instance Pretty Replicate where
 -- TODO add elongate/replicate constructors here
 
 -- | Controls that can be applied to a given pattern
-data ModType s
+data ModType b
   = ModTypeDegrade !Degrade
   | ModTypeEuclid !Euclid
-  | ModTypeSpeed !(Speed s)
+  | ModTypeSpeed !(Speed b)
   | ModTypeElongate !Elongate
   | ModTypeReplicate !Replicate
-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+  deriving stock (Eq, Ord, Show)
 
-instance (Pretty s) => Pretty (ModType s) where
+instance Pretty (ModType b) where
   pretty = \case
     ModTypeDegrade x -> pretty x
     ModTypeEuclid x -> pretty x
@@ -270,24 +272,15 @@ instance (Pretty s) => Pretty (ModType s) where
     ModTypeReplicate x -> pretty x
 
 -- | An expression modified by some control
-data Mod s r = Mod
+data Mod b r = Mod
   { modTarget :: !r
-  , modType :: !(ModType s)
+  , modType :: !(ModType b)
   }
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-instance (Pretty c, Pretty r) => Pretty (Mod c r) where
+instance (Pretty r) => Pretty (Mod b r) where
   pretty (Mod tar ty) = P.hcat [pretty tar, pretty ty]
 
-instance Bifunctor Mod where
-  bimap f g (Mod r mt) = Mod (g r) (fmap f mt)
-
-instance Bifoldable Mod where
-  bifoldr f g z (Mod r mt) = g r (foldr f z mt)
-
-instance Bitraversable Mod where
-  bitraverse f g (Mod r mt) = Mod <$> g r <*> traverse f mt
-
 -- * Groups
 
 -- | Presentation of a sequence - dot- or space-separated
@@ -363,16 +356,16 @@ instance (Pretty r) => Pretty (Poly r) where
 
 -- * Functor
 
-data PatF s a r
+data PatF b a r
   = PatPure !a
   | PatSilence
   | PatShort !Short
   | PatGroup !(Group r)
-  | PatMod !(Mod s r)
+  | PatMod !(Mod b r)
   | PatPoly !(Poly r)
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-instance Bifunctor (PatF s) where
+instance Bifunctor (PatF b) where
   bimap f g = \case
     PatPure a -> PatPure (f a)
     PatSilence -> PatSilence
@@ -381,7 +374,7 @@ instance Bifunctor (PatF s) where
     PatMod m -> PatMod (fmap g m)
     PatPoly p -> PatPoly (fmap g p)
 
-instance Bifoldable (PatF s) where
+instance Bifoldable (PatF b) where
   bifoldr f g = go
    where
     go z = \case
@@ -392,7 +385,7 @@ instance Bifoldable (PatF s) where
       PatMod m -> foldr g z m
       PatPoly p -> foldr g z p
 
-instance Bitraversable (PatF s) where
+instance Bitraversable (PatF b) where
   bitraverse f g = \case
     PatPure a -> fmap PatPure (f a)
     PatSilence -> pure PatSilence
@@ -401,10 +394,10 @@ instance Bitraversable (PatF s) where
     PatMod m -> fmap PatMod (traverse g m)
     PatPoly p -> fmap PatPoly (traverse g p)
 
-instance (IsString a) => IsString (PatF s a r) where
+instance (IsString a) => IsString (PatF b a r) where
   fromString = PatPure . fromString
 
-instance (Pretty s, Pretty a, Pretty r) => Pretty (PatF s a r) where
+instance (Pretty a, Pretty r) => Pretty (PatF b a r) where
   pretty a = case a of
     PatPure x -> pretty x
     PatSilence -> "~"
@@ -420,51 +413,11 @@ newtype Pat b a = Pat {unPat :: UnPat b a}
   deriving stock (Show)
   deriving newtype (Eq, Ord, Functor, Foldable, Pretty)
 
-type PatX b = PatF (Pat b Factor)
-
-type UnPat b = Jot (PatX b) b
+type UnPat b = Jot (PatF b) b
 
 instance Traversable (Pat a) where traverse f = fmap Pat . traverse f . unPat
 
-instance Bifunctor Pat where
-  bimap f g = Pat . go . unPat
-   where
-    go (JotP b pf) = JotP (f b) $
-      case pf of
-        PatPure a -> PatPure (g a)
-        PatSilence -> PatSilence
-        PatShort s -> PatShort s
-        PatGroup gs -> PatGroup (fmap go gs)
-        PatMod (Mod r m) -> PatMod (Mod (go r) (fmap (first f) m))
-        PatPoly (Poly rs mc) -> PatPoly (Poly (fmap go rs) mc)
-
-instance Bifoldable Pat where
-  bifoldr f g = flip (go . unPat)
-   where
-    go (JotP b pf) z = f b $
-      case pf of
-        PatPure a -> g a z
-        PatSilence -> z
-        PatShort _ -> z
-        PatGroup gs -> foldr go z gs
-        PatMod (Mod r m) -> go r (foldr (flip (bifoldr f (const id))) z m)
-        PatPoly (Poly rs _) -> foldr go z rs
-
-instance Bitraversable Pat where
-  bitraverse f g = fmap Pat . go . unPat
-   where
-    go (JotP b pf) =
-      JotP
-        <$> f b
-        <*> case pf of
-          PatPure a -> fmap PatPure (g a)
-          PatSilence -> pure PatSilence
-          PatShort s -> pure (PatShort s)
-          PatGroup gs -> fmap PatGroup (traverse go gs)
-          PatMod (Mod r m) -> fmap PatMod $ Mod <$> go r <*> traverse (bitraverse f pure) m
-          PatPoly (Poly rs mc) -> fmap (\rs' -> PatPoly (Poly rs' mc)) (traverse go rs)
-
-mkPat :: (Monoid b) => PatX b a (UnPat b a) -> Pat b a
+mkPat :: (Monoid b) => PatF b a (UnPat b a) -> Pat b a
 mkPat = Pat . JotP mempty
 
 mkPatGroup :: (Monoid b) => GroupType -> Seq (Pat b a) -> Pat b a

minipat/src/Minipat/Interp.hs

@@ -8,8 +8,6 @@ module Minipat.Interp
 where
 
 import Control.Exception (Exception)
-import Control.Monad.Except (Except, runExcept)
-import Control.Monad.Trans (lift)
 import Data.Ratio ((%))
 import Minipat.Ast
   ( Degrade (..)
@@ -21,15 +19,14 @@ import Minipat.Ast
   , ModType (..)
   , Pat (..)
   , PatF (..)
-  , PatX
   , Pattern (..)
   , Poly (..)
   , Replicate (..)
   , Speed (..)
   , SpeedDir (..)
   , factorValue
   )
-import Minipat.Rewrite (RwErr, RwT, rewriteM, throwRw)
+import Minipat.Rewrite (AnnoErr, Rw, patCataRw, runPatRw, throwRw)
 
 -- | An error interpreting a 'Pat' as a 'Stream'
 data InterpErr
@@ -39,37 +36,30 @@ data InterpErr
 
 instance Exception InterpErr
 
-type M b = Except (RwErr InterpErr b)
-
-runM :: M b a -> Either (RwErr InterpErr b) a
-runM = runExcept
-
 lookInterp
   :: (Pattern f)
-  => PatX b a (M b (f a, Rational))
-  -> RwT b (M b) (f a, Rational)
+  => PatF b a (f a, Rational)
+  -> Rw b InterpErr (f a, Rational)
 lookInterp = \case
   PatPure a -> pure (patPure a, 1)
   PatSilence -> pure (patEmpty, 1)
   PatShort _ -> throwRw InterpErrShort
   PatGroup (Group _ ty els) -> do
-    els' <- lift (sequenceA els)
     case ty of
-      GroupTypeSeq _ -> pure (patSeq els', 1)
-      GroupTypePar -> pure (patPar (fmap fst els'), 1)
+      GroupTypeSeq _ -> pure (patSeq els, 1)
+      GroupTypePar -> pure (patPar (fmap fst els), 1)
       GroupTypeRand ->
-        let els'' = fmap (\(el, w) -> patFastBy w el) els'
+        let els'' = fmap (\(el, w) -> patFastBy w el) els
             s = patRand els''
         in  pure (s, 1)
       GroupTypeAlt ->
-        let els'' = fmap (\(el, w) -> patFastBy w el) els'
+        let els'' = fmap (\(el, w) -> patFastBy w el) els
             s = patAlt els''
         in  pure (s, 1)
-  PatMod (Mod melw md) -> do
-    (el, w) <- lift melw
+  PatMod (Mod (el, w) md) -> do
     case md of
       ModTypeSpeed (Speed dir spat) -> do
-        spat' <- lift (subInterp spat)
+        spat' <- subInterp spat
         let f = case dir of
               SpeedDirFast -> patFast
               SpeedDirSlow -> patSlow
@@ -94,9 +84,8 @@ lookInterp = \case
         pure (el', w')
   PatPoly (Poly _ _) -> error "TODO"
 
-subInterp :: (Pattern f) => Pat b a -> M b (f a)
-subInterp = fmap fst . rewriteM lookInterp . unPat
+subInterp :: (Pattern f) => Pat b a -> Rw b InterpErr (f a)
+subInterp = fmap fst . patCataRw lookInterp
 
--- | Interpret the given 'Pat' as any 'Pattern'
-interpPat :: (Pattern f) => Pat b a -> Either (RwErr InterpErr b) (f a)
-interpPat = runM . subInterp
+interpPat :: (Pattern f) => Pat b a -> Either (AnnoErr b InterpErr) (f a)
+interpPat = runPatRw subInterp

minipat/src/Minipat/Norm.hs

@@ -8,6 +8,7 @@ import Bowtie (pattern JotP)
 import Data.Sequence (Seq (..))
 import Data.Sequence.NonEmpty (NESeq (..))
 import Data.Sequence.NonEmpty qualified as NESeq
+import Data.Void (Void)
 import Minipat.Ast
   ( Elongate (..)
   , Group (..)
@@ -16,12 +17,11 @@ import Minipat.Ast
   , ModType (..)
   , Pat (..)
   , PatF (..)
-  , PatX
   , Replicate (..)
   , Short (..)
   , UnPat
   )
-import Minipat.Rewrite (Rw, asksRw, overhaul, wrapRw)
+import Minipat.Rewrite (Rw, patNatRw, peeksRw, runPatRw, unwrapAnnoErr, wrapRw)
 
 foldNorm :: (b -> b -> b) -> Seq (UnPat b a) -> Seq (UnPat b a)
 foldNorm f = goFirst
@@ -49,7 +49,7 @@ foldNorm f = goFirst
             _ -> ws NESeq.|> y
       in  goRest ws' ys
 
-subNorm :: (b -> b -> b) -> PatX b a (UnPat b a) -> Rw b (UnPat b a)
+subNorm :: (b -> b -> b) -> PatF b a (UnPat b a) -> Rw b Void (UnPat b a)
 subNorm f x = case x of
   PatGroup (Group lvl ty ss) -> do
     -- Fold over sequences, eliminating time shorthands
@@ -58,15 +58,15 @@ subNorm f x = case x of
           _ -> ss
     -- Unwrap any empty groups or singletons we find
     case ss' of
-      Empty -> asksRw (`JotP` PatSilence)
+      Empty -> peeksRw (`JotP` PatSilence)
       q :<| Empty -> pure q
       _ -> wrapRw (PatGroup (Group lvl ty ss'))
   _ -> wrapRw x
 
 -- 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 = Pat . overhaul (subNorm f) . unPat
+normPat' f = unwrapAnnoErr . runPatRw (patNatRw (subNorm f))
 
 -- | Normalize the given pattern
 normPat :: (Semigroup b) => Pat b a -> Pat b a

minipat/src/Minipat/Parser.hs

@@ -156,12 +156,12 @@ factorP = do
 bracedP :: Brace -> P a -> P a
 bracedP b = L.betweenP (stripTokP (braceOpenChar b)) (tokP (braceCloseChar b))
 
-speedFastP :: P s -> P (Speed s)
+speedFastP :: P (PPat Factor) -> P (Speed Loc)
 speedFastP ps = do
   tokP '*'
   Speed SpeedDirFast <$> ps
 
-speedSlowP :: P s -> P (Speed s)
+speedSlowP :: P (PPat Factor) -> P (Speed Loc)
 speedSlowP ps = do
   tokP '/'
   Speed SpeedDirSlow <$> ps