diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index e5e29a47..211fec52 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -80,4 +80,4 @@ type PlayMap = Map.Map PatId PlayState -- tickArc :: Arc, -- tickNudge :: Double -- } --- deriving Show \ No newline at end of file +-- deriving Show diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 6662a8af..05f092e1 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -56,4 +56,4 @@ stripContext :: Pattern a -> Pattern a stripContext = setContext $ Context [] firstCycleValues :: Pattern a -> [a] -firstCycleValues pat = map value $ queryArc pat (Arc 0 1) \ No newline at end of file +firstCycleValues pat = map value $ queryArc pat (Arc 0 1) diff --git a/tidal-core/src/Sound/Tidal/Scales.hs b/tidal-core/src/Sound/Tidal/Scales.hs index c8a5e54c..84de7c44 100644 --- a/tidal-core/src/Sound/Tidal/Scales.hs +++ b/tidal-core/src/Sound/Tidal/Scales.hs @@ -308,7 +308,7 @@ getScale table sp p = noteInScale (fromMaybe [0] $ lookup scaleName table) n ) <$> p - <* sp + <* sp where octave s x = x `div` length s noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x) @@ -337,7 +337,7 @@ getScaleMod table sp f p = noteInScale (uniq $ f $ fromMaybe [0] $ lookup scaleName table) n ) <$> p - <* sp + <* sp where octave s x = x `div` length s noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x) diff --git a/tidal-core/test/Sound/Tidal/ParseTest.hs b/tidal-core/test/Sound/Tidal/ParseTest.hs index 6eebef98..9f7272da 100644 --- a/tidal-core/test/Sound/Tidal/ParseTest.hs +++ b/tidal-core/test/Sound/Tidal/ParseTest.hs @@ -4,7 +4,7 @@ module Sound.Tidal.ParseTest where import Control.Exception import Sound.Tidal.Core -import Sound.Tidal.ExceptionsTest (anyException, shouldThrow, shouldNotThrow) +import Sound.Tidal.ExceptionsTest (anyException, shouldNotThrow, shouldThrow) import Sound.Tidal.Pattern import Sound.Tidal.UI (_degradeBy) import Test.Microspec diff --git a/tidal-core/test/Sound/Tidal/StepwiseTest.hs b/tidal-core/test/Sound/Tidal/StepwiseTest.hs index eab344bb..02535348 100644 --- a/tidal-core/test/Sound/Tidal/StepwiseTest.hs +++ b/tidal-core/test/Sound/Tidal/StepwiseTest.hs @@ -162,4 +162,4 @@ run = -- ), -- ); -- }); --- }); \ No newline at end of file +-- }); diff --git a/tidal-core/test/TestUtils.hs b/tidal-core/test/TestUtils.hs index 74f43cc4..2e6335e2 100644 --- a/tidal-core/test/TestUtils.hs +++ b/tidal-core/test/TestUtils.hs @@ -17,8 +17,6 @@ import Sound.Tidal.Show as C import Sound.Tidal.Simple as C import Sound.Tidal.Stepwise as C import Sound.Tidal.UI as C -import Prelude hiding ((*>), (<*)) - import Test.Microspec import Prelude hiding ((*>), (<*)) @@ -68,4 +66,4 @@ stripContext :: Pattern a -> Pattern a stripContext = setContext $ Context [] firstCycleValues :: Pattern a -> [a] -firstCycleValues pat = map value $ queryArc pat (Arc 0 1) \ No newline at end of file +firstCycleValues pat = map value $ queryArc pat (Arc 0 1) diff --git a/tidal-parse-ffi/src/Sound/Tidal/Parse/FFI.hs b/tidal-parse-ffi/src/Sound/Tidal/Parse/FFI.hs index 457c5524..1db54ec8 100644 --- a/tidal-parse-ffi/src/Sound/Tidal/Parse/FFI.hs +++ b/tidal-parse-ffi/src/Sound/Tidal/Parse/FFI.hs @@ -1,90 +1,92 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.Parse.FFI where -import Foreign.C.String (CString, peekCString, newCString) +import Data.Aeson (ToJSON (..), object, (.=)) import qualified Data.Aeson as Aeson -import Data.Aeson (ToJSON(..), object, (.=)) import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) +import Foreign.C.String (CString, newCString, peekCString) import GHC.Generics (Generic) - +import Sound.Tidal.Params () import Sound.Tidal.Parse (parseTidal) import Sound.Tidal.Pattern -import Sound.Tidal.Params () import Sound.Tidal.Show () +import Text.Read (readMaybe) -- Newtype wrappers to avoid orphan instances -newtype JSONValue = JSONValue { unJSONValue :: Value } +newtype JSONValue = JSONValue {unJSONValue :: Value} deriving (Generic) instance ToJSON JSONValue where - toJSON (JSONValue (VS str)) = toJSON str - toJSON (JSONValue (VI i)) = toJSON i - toJSON (JSONValue (VF f)) = toJSON f - toJSON (JSONValue (VN num)) = toJSON $ show num - toJSON (JSONValue (VR r)) = toJSON $ show r - toJSON (JSONValue (VB b)) = toJSON b - toJSON (JSONValue (VX xs)) = toJSON xs - toJSON (JSONValue (VPattern pat)) = toJSON $ show pat - toJSON (JSONValue (VState f)) = toJSON $ show $ f Map.empty - toJSON (JSONValue (VList vs)) = toJSON $ map JSONValue vs + toJSON (JSONValue (VS str)) = toJSON str + toJSON (JSONValue (VI i)) = toJSON i + toJSON (JSONValue (VF f)) = toJSON f + toJSON (JSONValue (VN num)) = toJSON $ show num + toJSON (JSONValue (VR r)) = toJSON $ show r + toJSON (JSONValue (VB b)) = toJSON b + toJSON (JSONValue (VX xs)) = toJSON xs + toJSON (JSONValue (VPattern pat)) = toJSON $ show pat + toJSON (JSONValue (VState f)) = toJSON $ show $ f Map.empty + toJSON (JSONValue (VList vs)) = toJSON $ map JSONValue vs newtype JSONArcF = JSONArcF (ArcF Rational) deriving (Generic) instance ToJSON JSONArcF where - toJSON (JSONArcF (Arc arcStart arcStop)) = - object ["start" .= (realToFrac arcStart :: Double), - "stop" .= (realToFrac arcStop :: Double)] + toJSON (JSONArcF (Arc arcStart arcStop)) = + object + [ "start" .= (realToFrac arcStart :: Double), + "stop" .= (realToFrac arcStop :: Double) + ] newtype JSONEventF = JSONEventF (Event (Map.Map String Value)) deriving (Generic) instance ToJSON JSONEventF where - toJSON (JSONEventF (Event _ctx evWhole evPart evValue)) = - object [ "whole" .= fmap JSONArcF evWhole -- Handle Maybe - , "part" .= JSONArcF evPart - , "value" .= fmap JSONValue evValue ] - - + toJSON (JSONEventF (Event _ctx evWhole evPart evValue)) = + object + [ "whole" .= fmap JSONArcF evWhole, -- Handle Maybe + "part" .= JSONArcF evPart, + "value" .= fmap JSONValue evValue + ] -- Foreign export wrapper function foreign export ccall eval_pattern_c :: CString -> CString -> IO CString + eval_pattern_c :: CString -> CString -> IO CString eval_pattern_c cStr cArc = do - hsStr <- peekCString cStr - arcStr <- peekCString cArc - let arcLength = fromMaybe 16 (readMaybe arcStr :: Maybe Double) - result <- evalPattern hsStr arcLength - newCString result + hsStr <- peekCString cStr + arcStr <- peekCString cArc + let arcLength = fromMaybe 16 (readMaybe arcStr :: Maybe Double) + result <- evalPattern hsStr arcLength + newCString result -- Function to evaluate and return pattern events as a JSON string evalPattern :: String -> Double -> IO String evalPattern pat arcLen = do - let parsedResult = parseAndQuery pat arcLen - return $ B.unpack $ Aeson.encode (either encodeError (encodeSuccess arcLen) parsedResult) + let parsedResult = parseAndQuery pat arcLen + return $ B.unpack $ Aeson.encode (either encodeError (encodeSuccess arcLen) parsedResult) encodeError :: String -> Aeson.Value encodeError err = Aeson.object ["error" Aeson..= err] encodeSuccess :: Double -> [Event (Map.Map String Value)] -> Aeson.Value -encodeSuccess arcLen events = - Aeson.object ["arcLen" .= arcLen, "events" .= map JSONEventF events] +encodeSuccess arcLen events = + Aeson.object ["arcLen" .= arcLen, "events" .= map JSONEventF events] -- Helper functions to handle parsing and querying parseAndQuery :: String -> Double -> Either String [Event (Map.Map String Value)] parseAndQuery str arcLen = - case parseTidal str of - Left err -> Left (show err) - Right parsed -> - let arcTime = toRational arcLen - in Right $ query (stripContext parsed) (State (Arc 0 arcTime) Map.empty) + case parseTidal str of + Left err -> Left (show err) + Right parsed -> + let arcTime = toRational arcLen + in Right $ query (stripContext parsed) (State (Arc 0 arcTime) Map.empty) stripContext :: Pattern a -> Pattern a stripContext = setContext $ Context [] diff --git a/tidal-parse-ffi/test/Sound/Tidal/TidalParseFFITest.hs b/tidal-parse-ffi/test/Sound/Tidal/TidalParseFFITest.hs index b55dab57..559d0c6a 100644 --- a/tidal-parse-ffi/test/Sound/Tidal/TidalParseFFITest.hs +++ b/tidal-parse-ffi/test/Sound/Tidal/TidalParseFFITest.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.TidalParseFFITest where -import Foreign.C.String (CString, peekCString, newCString) -import Test.HUnit import Data.Aeson (Value, encode, object, (.=)) import qualified Data.ByteString.Lazy.Char8 as B +import Foreign.C.String (CString, newCString, peekCString) +import Test.HUnit -- Foreign function import foreign import ccall "eval_pattern_c" eval_pattern_c :: CString -> CString -> IO CString @@ -14,33 +14,34 @@ foreign import ccall "eval_pattern_c" eval_pattern_c :: CString -> CString -> IO -- Utility function to run FFI test ffiTest :: String -> String -> IO Bool ffiTest input arcLen = do - cInput <- newCString input - cArcLen <- newCString arcLen - resultPtr <- eval_pattern_c cInput cArcLen - result <- peekCString resultPtr - let expected = B.unpack $ encode mockJSON - return (result == expected) + cInput <- newCString input + cArcLen <- newCString arcLen + resultPtr <- eval_pattern_c cInput cArcLen + result <- peekCString resultPtr + let expected = B.unpack $ encode mockJSON + return (result == expected) -- Mock the exact expected JSON output mockJSON :: Value -mockJSON = object - [ "arcLen" .= (1 :: Int) - , "events" .= - [ object [ - "part" .= object ["start" .= (0 :: Double), "stop" .= (0.5 :: Double)] - , "value" .= object ["s" .= ("bd" :: String)] - , "whole" .= object ["start" .= (0 :: Double), "stop" .= (0.5 :: Double)] - ] - , object [ - "part" .= object ["start" .= (0.5 :: Double), "stop" .= (1 :: Double)] - , "value" .= object ["s" .= ("cd" :: String)] - , "whole" .= object ["start" .= (0.5 :: Double), "stop" .= (1 :: Double)] - ] - ] +mockJSON = + object + [ "arcLen" .= (1 :: Int), + "events" + .= [ object + [ "part" .= object ["start" .= (0 :: Double), "stop" .= (0.5 :: Double)], + "value" .= object ["s" .= ("bd" :: String)], + "whole" .= object ["start" .= (0 :: Double), "stop" .= (0.5 :: Double)] + ], + object + [ "part" .= object ["start" .= (0.5 :: Double), "stop" .= (1 :: Double)], + "value" .= object ["s" .= ("cd" :: String)], + "whole" .= object ["start" .= (0.5 :: Double), "stop" .= (1 :: Double)] + ] + ] ] -- Test case with the mocked JSON output testFullPattern :: Test testFullPattern = TestCase $ do - result <- ffiTest "s $ \"bd cd\"" "1" - assertBool "Full pattern 's $ \"bd cd\"' should return the expected JSON" result + result <- ffiTest "s $ \"bd cd\"" "1" + assertBool "Full pattern 's $ \"bd cd\"' should return the expected JSON" result diff --git a/tidal-parse-ffi/test/Test.hs b/tidal-parse-ffi/test/Test.hs index 4333cca1..c8064f92 100644 --- a/tidal-parse-ffi/test/Test.hs +++ b/tidal-parse-ffi/test/Test.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.HUnit import Sound.Tidal.TidalParseFFITest (testFullPattern) +import Test.HUnit main :: IO Counts main = runTestTT $ TestList [testFullPattern] diff --git a/tidal-parse/src/Sound/Tidal/Parse.hs b/tidal-parse/src/Sound/Tidal/Parse.hs index e381dadd..a8823324 100644 --- a/tidal-parse/src/Sound/Tidal/Parse.hs +++ b/tidal-parse/src/Sound/Tidal/Parse.hs @@ -13,19 +13,16 @@ import Data.Char import Data.List (dropWhileEnd) import qualified Data.Text import Language.Haskellish as Haskellish - -import Sound.Tidal.ParseBP (Enumerable, Parseable, parseBP) - -import Sound.Tidal.UI as T import Sound.Tidal.Chords as T import Sound.Tidal.Control as T import Sound.Tidal.Core as T import Sound.Tidal.Params as T +import Sound.Tidal.Parse.TH +import Sound.Tidal.ParseBP (Enumerable, Parseable, parseBP) import Sound.Tidal.Pattern as T import Sound.Tidal.Scales as T import Sound.Tidal.Simple as T - -import Sound.Tidal.Parse.TH +import Sound.Tidal.UI as T type H = Haskellish () diff --git a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs index 7ab41f37..1f65b560 100644 --- a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs +++ b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs @@ -4,19 +4,16 @@ module Sound.Tidal.TidalParseTest where import Data.Either import qualified Data.Map.Strict as Map - import Sound.Tidal.Chords as Tidal import Sound.Tidal.Control as Tidal import Sound.Tidal.Core as Tidal import Sound.Tidal.Params as Tidal -import Sound.Tidal.Pattern as Tidal -import Sound.Tidal.UI as Tidal - import Sound.Tidal.Parse +import Sound.Tidal.Pattern as Tidal import Sound.Tidal.Scales () import Sound.Tidal.Show () import Sound.Tidal.Simple () - +import Sound.Tidal.UI as Tidal import Test.Microspec hiding (run) stripContext :: Pattern a -> Pattern a