etc

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

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)

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