From f7b1bc1b2baffc3bc6f242c6f678200a9fe672e8 Mon Sep 17 00:00:00 2001
From: Eric Conlon <37287+ejconlon@users.noreply.github.com>
Date: Mon, 5 Feb 2024 18:14:35 -0800
Subject: [PATCH] etc

---
 minipat-dirt/minipat-dirt.cabal          |  1 -
 minipat-dirt/src/Minipat/Dirt/Attrs.hs   | 19 ++++-
 minipat-dirt/src/Minipat/Dirt/Parser.hs  | 68 -----------------
 minipat-dirt/src/Minipat/Dirt/Prelude.hs | 93 ++++++++++++++++++++----
 4 files changed, 95 insertions(+), 86 deletions(-)
 delete mode 100644 minipat-dirt/src/Minipat/Dirt/Parser.hs

diff --git a/minipat-dirt/minipat-dirt.cabal b/minipat-dirt/minipat-dirt.cabal
index 155b707..c2f09c4 100644
--- a/minipat-dirt/minipat-dirt.cabal
+++ b/minipat-dirt/minipat-dirt.cabal
@@ -31,7 +31,6 @@ library
       Minipat.Dirt.Logger
       Minipat.Dirt.Notes
       Minipat.Dirt.Osc
-      Minipat.Dirt.Parser
       Minipat.Dirt.Prelude
       Minipat.Dirt.Resources
       Minipat.Dirt.Test
diff --git a/minipat-dirt/src/Minipat/Dirt/Attrs.hs b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
index 6fee116..8d3755e 100644
--- a/minipat-dirt/src/Minipat/Dirt/Attrs.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Minipat.Dirt.Attrs
   ( DatumProxy (..)
   , datumProxyType
@@ -8,11 +10,19 @@ module Minipat.Dirt.Attrs
   )
 where
 
-import Dahdit.Midi.Osc (Datum, DatumType (..), IsDatum (..))
+import Dahdit.Midi.Osc (Datum (..), DatumType (..), IsDatum (..))
 import Data.Int (Int32, Int64)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
+import Minipat.Ast (Ident (..))
+import Minipat.Dirt.Notes (Note (..))
+
+data Sound = Sound
+  { soundIdent :: !Ident
+  , soundNote :: !(Maybe Note)
+  }
+  deriving stock (Eq, Ord, Show)
 
 data DatumProxy a where
   DatumProxyInt32 :: DatumProxy Int32
@@ -49,5 +59,8 @@ instance IsAttrs Attrs where
 instance (IsDatum a) => IsAttrs (Attr a) where
   toAttrs (Attr k v) = Map.singleton k (toDatum v)
 
--- instance IsAttrs Note where
---   toAttrs (Note n) = Map.singleton "note" (DatumInt32 (fromInteger n))
+instance IsAttrs Note where
+  toAttrs (Note n) = Map.singleton "note" (DatumInt32 (fromInteger n))
+
+instance IsAttrs Sound where
+  toAttrs (Sound s mn) = Map.insert "sound" (DatumString (unIdent s)) (maybe Map.empty toAttrs mn)
diff --git a/minipat-dirt/src/Minipat/Dirt/Parser.hs b/minipat-dirt/src/Minipat/Dirt/Parser.hs
deleted file mode 100644
index 34fdaa3..0000000
--- a/minipat-dirt/src/Minipat/Dirt/Parser.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Minipat.Dirt.Parser
-  ( datumPat
-  , notePat
-  , soundPat
-  )
-where
-
-import Control.Applicative (Alternative (..))
-import Dahdit.Midi.Osc (Datum (..))
-import Data.Char (isAlpha, isAlphaNum)
-import Data.Int (Int32)
-import Data.Text (Text)
-import Data.Text qualified as T
-import Looksee qualified as L
-import Minipat.Ast (Ident (..), Pattern (..), Select (..))
-import Minipat.Dirt.Attrs (Attr (..), Attrs, DatumProxy (..), attrs)
-import Minipat.Dirt.Notes
-import Minipat.Eval (evalPat)
-import Minipat.Parser (P, identP, selectP)
-
-datumP :: DatumProxy a -> P a
-datumP = \case
-  DatumProxyInt32 -> fmap fromInteger L.intP
-  DatumProxyInt64 -> fmap fromInteger L.intP
-  DatumProxyFloat -> fmap realToFrac L.sciP
-  DatumProxyDouble -> fmap realToFrac L.sciP
-  DatumProxyString -> fmap unIdent identP
-
--- TODO figure out out to propagate error
-parsePat :: (Pattern f) => P a -> Text -> f a
-parsePat p = either (pure patEmpty) id . evalPat p
-
-datumPat :: (Pattern f) => DatumProxy a -> Text -> f a
-datumPat = parsePat . datumP
-
-octNoteP :: P OctNote
-octNoteP = do
-  noteRaw <- L.takeWhile1P isAlpha
-  case convNoteName noteRaw of
-    Nothing -> fail ("Not note name: " ++ T.unpack noteRaw)
-    Just nn -> do
-      moct <- fmap (fmap (Octave . fromInteger)) (L.optP L.intP)
-      pure (OctNote moct nn)
-
-noteP :: P Note
-noteP =
-  fmap octToNote octNoteP <|> fmap (Note . fromInteger) L.intP
-
-chordNameP :: P ChordName
-chordNameP = do
-  nameRaw <- L.takeWhile1P isAlphaNum
-  case convChordName nameRaw of
-    Nothing -> fail ("Not chord name: " ++ T.unpack nameRaw)
-    Just cn -> pure cn
-
--- TODO IsAttrs instance for Note instead
-notePat :: (Pattern f) => Text -> f (Attr Int32)
-notePat = fmap conv . parsePat noteP
- where
-  conv = Attr "note" . fromIntegral . unNote
-
--- TODO IsAttrs instance for sound
-soundPat :: (Pattern f) => Text -> f Attrs
-soundPat = fmap conv . parsePat (selectP identP L.uintP)
- where
-  conv (Select a ms) = attrs (("sound", DatumString (unIdent a)) : maybe [] (\n -> [("note", DatumInt32 (fromInteger n))]) ms)
diff --git a/minipat-dirt/src/Minipat/Dirt/Prelude.hs b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
index fb4e27b..ed6118c 100644
--- a/minipat-dirt/src/Minipat/Dirt/Prelude.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
@@ -2,37 +2,102 @@
 
 module Minipat.Dirt.Prelude where
 
+-- TODO Explicit exports
+
+import Control.Applicative (Alternative (..))
+import Dahdit.Midi.Osc (Datum (..))
+import Data.Char (isAlpha, isAlphaNum)
 import Data.Int (Int32)
+import Data.Map.Strict qualified as Map
 import Data.Text (Text)
-import Minipat.Dirt.Attrs (Attr (..), Attrs, DatumProxy, IsAttrs (..))
-import Minipat.Dirt.Parser (datumPat, notePat, soundPat)
+import Data.Text qualified as T
+import Looksee qualified as L
+import Minipat.Ast (Ident (..), Pattern (..), Select (..))
+import Minipat.Dirt.Attrs (Attr (..), Attrs, DatumProxy (..), IsAttrs (..))
+import Minipat.Dirt.Notes
+import Minipat.Eval (evalPat)
+import Minipat.Parser (P, identP, selectP)
 import Minipat.Stream (Stream (..), streamInnerBind)
 
+-- Start with some private parsing stuff
+
+datumP :: DatumProxy a -> P a
+datumP = \case
+  DatumProxyInt32 -> fmap fromInteger L.intP
+  DatumProxyInt64 -> fmap fromInteger L.intP
+  DatumProxyFloat -> fmap realToFrac L.sciP
+  DatumProxyDouble -> fmap realToFrac L.sciP
+  DatumProxyString -> fmap unIdent identP
+
+-- TODO figure out out to propagate error
+parsePat :: (Pattern f) => P a -> Text -> f a
+parsePat p = either (pure patEmpty) id . evalPat p
+
+datumPat :: (Pattern f) => DatumProxy a -> Text -> f a
+datumPat = parsePat . datumP
+
+octNoteP :: P OctNote
+octNoteP = do
+  noteRaw <- L.takeWhile1P isAlpha
+  case convNoteName noteRaw of
+    Nothing -> fail ("Not note name: " ++ T.unpack noteRaw)
+    Just nn -> do
+      moct <- fmap (fmap (Octave . fromInteger)) (L.optP L.intP)
+      pure (OctNote moct nn)
+
+noteP :: P Note
+noteP =
+  fmap octToNote octNoteP <|> fmap (Note . fromInteger) L.intP
+
+chordNameP :: P ChordName
+chordNameP = do
+  nameRaw <- L.takeWhile1P isAlphaNum
+  case convChordName nameRaw of
+    Nothing -> fail ("Not chord name: " ++ T.unpack nameRaw)
+    Just cn -> pure cn
+
+-- General combinators
+
 setIn, (#) :: (IsAttrs a, IsAttrs b) => Stream a -> Stream b -> Stream Attrs
 setIn p1 p2 = streamInnerBind p1 $ \m1 ->
   let a1 = toAttrs m1 in fmap (\m2 -> toAttrs m2 <> a1) p2
 (#) = setIn
 
-pF :: (Real a) => Text -> Stream a -> Stream (Attr Float)
+pF :: (Pattern f, Real a) => Text -> f a -> f (Attr Float)
 pF k = fmap (Attr k . realToFrac)
 
-pI :: (Integral a) => Text -> Stream a -> Stream (Attr Int32)
+pI :: (Pattern f, Integral a) => Text -> f a -> f (Attr Int32)
 pI k = fmap (Attr k . fromIntegral)
 
-stream :: Text -> Stream a -> Stream (Attr a)
-stream k = fmap (Attr k)
+attrPat :: Pattern f => Text -> f a -> f (Attr a)
+attrPat k = fmap (Attr k)
+
+datumAttrPat :: Pattern f => DatumProxy a -> Text -> Text -> f (Attr a)
+datumAttrPat dp k = attrPat k . datumPat dp
 
-pat :: DatumProxy a -> Text -> Text -> Stream (Attr a)
-pat dp k = stream k . datumPat dp
+-- Specific combinators
 
-sound, s :: Text -> Stream Attrs
-sound = soundPat
+data Sound = Sound
+  { soundIdent :: !Ident
+  , soundNote :: !(Maybe Note)
+  }
+  deriving stock (Eq, Ord, Show)
+
+instance IsAttrs Sound where
+  toAttrs (Sound so mn) = Map.insert "sound" (DatumString (unIdent so)) (maybe Map.empty toAttrs mn)
+
+sound, s :: Pattern f => Text -> f Sound
+sound = fmap conv . parsePat (selectP identP noteP)
+ where
+  conv (Select so mn) = Sound so mn
 s = sound
 
-note, n :: Text -> Stream (Attr Int32)
-note = notePat
+note, n :: Pattern f => Text -> f Note
+note = parsePat noteP
 n = note
 
+-- Params
+
 -- TODO check these are all float, not int
 -- Basic effect parameters
 accelerate
@@ -65,7 +130,7 @@ accelerate
   , sustain
   , tremolodepth
   , tremolorate
-    :: (Real a) => Stream a -> Stream (Attr Float)
+    :: (Pattern f, Real a) => f a -> f (Attr Float)
 accelerate = pF "accelerate"
 attack = pF "attack"
 bandf = pF "bandf"
@@ -117,7 +182,7 @@ accel
   , sz
   , tremdp
   , tremr
-    :: (Real a) => Stream a -> Stream (Attr Float)
+    :: (Pattern f, Real a) => f a -> f (Attr Float)
 att = attack
 bpf = bandf
 bpq = bandq