etc

minipat-dirt/src/Minipat/Dirt/Attrs.hs

@@ -5,8 +5,14 @@ module Minipat.Dirt.Attrs
   , datumProxyType
   , Attr (..)
   , Attrs
-  , attrs
+  , attrsSingleton
+  , attrsFromList
+  , attrsLookup
+  , attrsInsert
+  , attrsDelete
+  , attrsToList
   , IsAttrs (..)
+  , attrsMerge
   )
 where
 
@@ -17,6 +23,8 @@ import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import Minipat.Ast (Ident (..))
 import Minipat.Dirt.Notes (Note (..))
+import Prettyprinter (Doc, Pretty (..))
+import Prettyprinter qualified as P
 
 data Sound = Sound
   { soundIdent :: !Ident
@@ -39,16 +47,54 @@ datumProxyType = \case
   DatumProxyDouble -> DatumTypeDouble
   DatumProxyString -> DatumTypeString
 
+prettyDatum :: Datum -> Doc ann
+prettyDatum = \case
+  DatumInt32 x -> pretty x
+  DatumInt64 x -> pretty x
+  DatumFloat x -> pretty x
+  DatumDouble x -> pretty x
+  DatumString x -> pretty x
+  DatumBlob _ -> "<BLOB>"
+  DatumTime _ -> "<TIME>"
+  DatumMidi _ -> "<MIDI>"
+
 data Attr a = Attr
   { attrKey :: !Text
   , attrVal :: !a
   }
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-type Attrs = Map Text Datum
+newtype Attrs = Attrs {unAttrs :: Map Text Datum}
+  deriving stock (Show)
+  deriving newtype (Eq, Ord)
+
+instance Semigroup Attrs where
+  -- Flip order to allow keys on the right to win
+  Attrs m1 <> Attrs m2 = Attrs (m2 <> m1)
+
+instance Monoid Attrs where
+  mempty = Attrs Map.empty
+
+instance Pretty Attrs where
+  pretty as = P.hsep ("{" : P.punctuate "," (fmap (\(k, v) -> P.hcat [pretty k, ": ", prettyDatum v]) (attrsToList as)) ++ ["}"])
+
+attrsSingleton :: Text -> Datum -> Attrs
+attrsSingleton k v = Attrs (Map.singleton k v)
 
-attrs :: [(Text, Datum)] -> Attrs
-attrs = Map.fromList
+attrsFromList :: [(Text, Datum)] -> Attrs
+attrsFromList = Attrs . Map.fromList
+
+attrsLookup :: Text -> Attrs -> Maybe Datum
+attrsLookup k (Attrs m) = Map.lookup k m
+
+attrsInsert :: Text -> Datum -> Attrs -> Attrs
+attrsInsert k v (Attrs m) = Attrs (Map.insert k v m)
+
+attrsDelete :: Text -> Attrs -> Attrs
+attrsDelete k (Attrs m) = Attrs (Map.delete k m)
+
+attrsToList :: Attrs -> [(Text, Datum)]
+attrsToList = Map.toList . unAttrs
 
 class IsAttrs a where
   toAttrs :: a -> Attrs
@@ -57,7 +103,10 @@ instance IsAttrs Attrs where
   toAttrs = id
 
 instance (IsDatum a) => IsAttrs (Attr a) where
-  toAttrs (Attr k v) = Map.singleton k (toDatum v)
+  toAttrs (Attr k v) = attrsSingleton k (toDatum v)
 
 instance IsAttrs Note where
-  toAttrs (Note n) = Map.singleton "note" (DatumInt32 (fromInteger n))
+  toAttrs (Note n) = attrsSingleton "note" (DatumInt32 (fromInteger n))
+
+attrsMerge :: (IsAttrs a, IsAttrs b) => a -> b -> Attrs
+attrsMerge a b = toAttrs a <> toAttrs b

minipat-dirt/src/Minipat/Dirt/Boot.hs

@@ -8,6 +8,7 @@ import Minipat.Dirt.Logger qualified as L
 import Minipat.EStream (EStream)
 import Minipat.Stream (Stream)
 import Nanotime (TimeDelta)
+import Prettyprinter (Pretty)
 
 class Dirt where
   dirt :: C.St
@@ -21,6 +22,9 @@ initialize = do
 dispose :: (Dirt) => IO ()
 dispose = C.disposeSt dirt
 
+getDebug :: (Dirt) => IO Bool
+getDebug = C.getDebug dirt
+
 getCps :: (Dirt) => IO Rational
 getCps = C.getCps dirt
 
@@ -39,6 +43,9 @@ getCycle = C.getCycle dirt
 getTempo :: (Dirt) => IO Rational
 getTempo = C.getTempo dirt
 
+setDebug :: (Dirt) => Bool -> IO ()
+setDebug = C.setDebug dirt
+
 setCps :: (Dirt) => Rational -> IO ()
 setCps = C.setCps dirt
 
@@ -75,7 +82,10 @@ stop = setPlaying False
 handshake :: (Dirt) => IO ()
 handshake = C.handshake dirt
 
-peek :: (Dirt, Show a) => EStream a -> IO ()
+checkTasks :: (Dirt) => IO ()
+checkTasks = C.checkTasks dirt
+
+peek :: (Dirt, Pretty a) => EStream a -> IO ()
 peek = C.peek dirt
 
 d :: (Dirt, IsAttrs a) => Integer -> EStream a -> IO ()