diff --git a/music-preludes.cabal b/music-preludes.cabal --- a/music-preludes.cabal +++ b/music-preludes.cabal @@ -1,6 +1,6 @@ name: music-preludes -version: 1.6.2 +version: 1.7 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -22,7 +22,7 @@ library build-depends: base >= 4 && < 5, - lens, + lens >= 4.1.2 && < 4.2, split, unix, containers, @@ -36,18 +36,21 @@ data-default, monadplus, reverse-apply, - lilypond == 1.6.2, - musicxml2 == 1.6.2, - music-score == 1.6.2, - music-pitch == 1.6.2, - music-dynamics == 1.6.2, - music-parts == 1.6.2, - music-pitch-literal == 1.6.2, - music-dynamics-literal == 1.6.2 - exposed-modules: Music.Prelude.Basic + lilypond == 1.7, + musicxml2 == 1.7, + music-score == 1.7, + music-pitch == 1.7, + music-dynamics == 1.7, + music-parts == 1.7, + music-pitch-literal == 1.7, + music-dynamics-literal == 1.7, + -- For examples: + async + exposed-modules: Music.Prelude + Music.Prelude.Basic Music.Prelude.Standard - Music.Prelude.Piano - Music.Prelude.StringQuartet + -- Music.Prelude.Piano + -- Music.Prelude.StringQuartet Music.Prelude.CmdLine Music.Prelude.Instances hs-source-dirs: src diff --git a/src/Music/Prelude.hs b/src/Music/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Music/Prelude.hs @@ -0,0 +1,23 @@ + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable +-- +-- The Music Suite comes with many standard preludes. +-- +-- This module reexports "Music.Prelude.Standard" for convenience. +-- +------------------------------------------------------------------------------------- + +module Music.Prelude ( + module Music.Prelude.Standard + ) where + +import Music.Prelude.Standard + diff --git a/src/Music/Prelude/Basic.hs b/src/Music/Prelude/Basic.hs --- a/src/Music/Prelude/Basic.hs +++ b/src/Music/Prelude/Basic.hs @@ -40,15 +40,16 @@ import Music.Dynamics import Music.Parts hiding (Part) -import Music.Pitch hiding (Fifths, Interval, Note, Part, +import Music.Pitch hiding (Fifths, Note, Part, pitch) -- Need to export Pitch.Pitch for transf for now import qualified Music.Pitch -import Music.Score hiding (Pitch) +import Music.Score hiding (Pitch, Interval) import Control.Lens.Operators hiding ((<.>), (<|), (|>)) import Control.Monad.Plus +import Data.Semigroup (Product) import Music.Prelude.Instances () @@ -65,19 +66,19 @@ asTrack = id type BasicNote = (PartT BasicPart - (TremoloT - (TextT - (ArticulationT + (TextT + (TieT + (SlideT + (TremoloT (HarmonicT - (TieT - (SlideT - (DynamicT - (ChordT - BasicPitch))))))))) + (ArticulationT (Sum Double, Sum Double) + (DynamicT (Sum Double) + [Behavior BasicPitch])))))))) type BasicPitch = Music.Pitch.Pitch open = openLilypond . asScore -play = playMidiIO mempty . asScore +play = error "Not implemented: play" openAndPlay x = open x >> play x + diff --git a/src/Music/Prelude/CmdLine.hs b/src/Music/Prelude/CmdLine.hs --- a/src/Music/Prelude/CmdLine.hs +++ b/src/Music/Prelude/CmdLine.hs @@ -6,6 +6,7 @@ versionString ) where +import Control.Exception import Data.Version (showVersion) import Data.Monoid import Options.Applicative @@ -28,7 +29,7 @@ -- TODO Can not link due to haskell/cabal#1759 versionString :: String -versionString = "1.6" +versionString = "1.7" -- versionString = showVersion version data Options = Options { @@ -47,8 +48,11 @@ runConverter func ext (Options prelude outFile inFile) = translateFile func ext prelude (Just inFile) outFile -converterMain :: String -> String -> String -> IO () -converterMain func ext pgmName = execParser opts >>= runConverter func ext +converterMain :: String -> String -> IO () +converterMain func ext = getProgName >>= converterMain' func ext + +converterMain' :: String -> String -> String -> IO () +converterMain' func ext pgmName = execParser opts >>= runConverter func ext where opts = info (helper <*> converterOptions) @@ -90,11 +94,12 @@ withSystemTempDirectory "music-suite." $ \tmpDir -> do let tmpFile = tmpDir ++ "/" ++ takeFileName inFile + let opts = ["-XOverloadedStrings", "-XNoMonomorphismRestriction", "-XTypeFamilies"] putStrLn $ "Converting music..." writeFile tmpFile newScore withMusicSuiteInScope $ do putStrLn $ "Writing '" ++ outFile ++ "'..." - rawSystem "runhaskell" [tmpFile] + rawSystem "runhaskell" (opts <> [tmpFile]) >>= \e -> if e == ExitSuccess then return () else fail ("Could not convert"++inFile) return () where @@ -131,16 +136,18 @@ -- ... -- @ -- -withEnv :: String -> (Maybe String -> String) -> IO a -> IO () +withEnv :: String -> (Maybe String -> String) -> IO a -> IO a withEnv n f k = do x <- PE.getEnv n PE.setEnv n (f x) True - k + res <- k case x of - Nothing -> PE.unsetEnv n - Just x2 -> PE.setEnv n x2 True + Nothing -> PE.unsetEnv n >> return res + Just x2 -> PE.setEnv n x2 True >> return res --- TODO if no music-util, use "" +withMusicSuiteInScope :: IO a -> IO a withMusicSuiteInScope k = do - packagePath <- readProcess "music-util" ["package-path"] "" - withEnv "GHC_PACKAGE_PATH" (const packagePath) k + r <- try $ readProcess "music-util" ["package-path"] "" + case r of + Left x -> let _ = (x::SomeException) in withEnv "GHC_PACKAGE_PATH" (const "") k + Right packagePath -> withEnv "GHC_PACKAGE_PATH" (const packagePath) k diff --git a/src/Music/Prelude/Instances.hs b/src/Music/Prelude/Instances.hs --- a/src/Music/Prelude/Instances.hs +++ b/src/Music/Prelude/Instances.hs @@ -39,39 +39,73 @@ deriving instance Typeable Music.Parts.Part +instance Transformable Music.Parts.Part where + transform _ = id +type instance Music.Score.Part Music.Parts.Part = Music.Parts.Part +type instance SetPart a Music.Parts.Part = a + +instance (Transformable a, a ~ Music.Score.Part a) => HasPart Music.Parts.Part a where + part = ($) +instance (Transformable a, a ~ Music.Score.Part a) => HasParts Music.Parts.Part a where + parts = ($) + + + +instance Transformable BasicPart where + transform _ = id type instance Music.Score.Part BasicPart = BasicPart -instance HasPart BasicPart where - getPart = id - modifyPart = id +type instance SetPart a BasicPart = a --- FIXME -instance Delayable Pitch -instance Stretchable Pitch +instance (Transformable a, a ~ Music.Score.Part a) => HasPart BasicPart a where + part = ($) +instance (Transformable a, a ~ Music.Score.Part a) => HasParts BasicPart a where + parts = ($) + +instance Transformable Pitch where + transform _ = id type instance Score.Pitch Pitch = Pitch +type instance SetPitch a Pitch = a -instance HasGetPitch Pitch where - __getPitch = id -instance (a ~ Score.Pitch a) => HasSetPitch Pitch a where - type SetPitch a Pitch = a - __mapPitch = id +instance (Transformable a, a ~ Score.Pitch a) => HasPitch Pitch a where + pitch = ($) +instance (Transformable a, a ~ Score.Pitch a) => HasPitches Pitch a where + pitches = ($) + instance Tiable Pitch where beginTie = id endTie = id -instance HasMidi Semitones where - getMidi a = getMidi $ (fromIntegral a :: Integer) +instance HasBackendNote Midi Semitones where + exportNote b = exportNote b . fmap toInteger + exportChord b = exportChord b . fmap (fmap toInteger) -instance HasMidi Pitch where - getMidi p = getMidi $ semitones (p .-. c) +instance HasBackendNote Midi Pitch where + exportNote b = exportNote b . fmap (\p -> semitones (p .-. c)) + exportChord b = exportChord b . fmap (fmap (\p -> semitones (p .-. c))) -instance HasMusicXml Pitch where - getMusicXml (realToFrac -> d) = (`Xml.note` d) . snd3 Just . spellPitch 4 - getMusicXmlChord (realToFrac -> d) = (`Xml.chord` (realToFrac d)) . fmap (snd3 Just . spellPitch 4) +instance HasBackendNote SuperCollider Semitones where + exportNote b = exportNote b . fmap toInteger + exportChord b = exportChord b . fmap (fmap toInteger) -instance HasLilypond Pitch where - getLilypond d = (^*realToFrac (d*4)) . Lilypond.note . pitchLilypond . Lilypond.Pitch . spellPitch 5 - getLilypondChord d = (^*realToFrac (d*4)) . Lilypond.chord . fmap (pitchLilypond . Lilypond.Pitch . spellPitch 5) +instance HasBackendNote SuperCollider Pitch where + exportNote b = exportNote b . fmap (\p -> semitones (p .-. c)) + exportChord b = exportChord b . fmap (fmap (\p -> semitones (p .-. c))) + +instance HasBackendNote MusicXml Pitch where + exportNote _ (XmlContext d Nothing) = Xml.rest (realToFrac d) + exportNote _ (XmlContext d (Just x)) = (`Xml.note` realToFrac d) . snd3 Just . spellPitch 4 $ x + + exportChord _ (XmlContext d Nothing) = Xml.rest (realToFrac d) + exportChord _ (XmlContext d (Just xs)) = (`Xml.chord` (realToFrac d)) . fmap (snd3 Just . spellPitch 4) $ xs + +instance HasBackendNote Lilypond Pitch where + exportNote _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest + exportNote _ (LyContext d (Just x)) = (^*realToFrac (d*4)) . Lilypond.note . pitchLilypond . Lilypond.Pitch . spellPitch 5 $ x + + exportChord _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest + exportChord _ (LyContext d (Just xs)) = (^*realToFrac (d*4)) . Lilypond.chord . fmap (pitchLilypond . Lilypond.Pitch . spellPitch 5) $ xs + -- TODO move snd3 f (a, b, c) = (a, f b, c) pitchLilypond a = Lilypond.NotePitch a Nothing @@ -96,3 +130,16 @@ 41 -> 48 42 -> 48 x -> x + +instance HasLilypondInstrument BasicPart where + getLilypondClef = 0 + +instance HasLilypondInstrument Music.Parts.Part where + getLilypondClef = defaultClef + +instance HasMusicXmlInstrument BasicPart where + getMusicXmlClef = 0 + +instance HasMusicXmlInstrument Music.Parts.Part where + getMusicXmlClef = defaultClef + diff --git a/src/Music/Prelude/Piano.hs b/src/Music/Prelude/Piano.hs deleted file mode 100644 --- a/src/Music/Prelude/Piano.hs +++ /dev/null @@ -1,47 +0,0 @@ - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- A basic music representation for piano. --- -------------------------------------------------------------------------------------- - -module Music.Prelude.Piano ( - module Music.Score, - PianoPart, - Note, - asScore - ) where - -import Data.AffineSpace.Point -import Data.Typeable -import Music.Dynamics.Literal -import qualified Music.Lilypond as Lilypond -import qualified Music.MusicXml.Simple as Xml -import Music.Pitch -import Music.Score hiding (Interval, Note, Pitch) -import qualified Music.Score as Score - -asScore :: Score Note -> Score Note -asScore = id - -data PianoPart - = Pno - deriving (Eq, Ord, Enum) - -instance Show PianoPart where - show Pno = "Piano" - -type Note = (PartT PianoPart (TieT - (TremoloT (HarmonicT (SlideT - (DynamicT (ArticulationT (TextT Integer)))))))) diff --git a/src/Music/Prelude/Standard.hs b/src/Music/Prelude/Standard.hs --- a/src/Music/Prelude/Standard.hs +++ b/src/Music/Prelude/Standard.hs @@ -62,22 +62,24 @@ -- instance Show BasicPart where -- show _ = "" -type Note = (PartT Part - (TremoloT - (TextT - (ArticulationT - (HarmonicT - (TieT +type Note = + (PartT Part + (TieT + (ColorT + (TextT + (TremoloT + (HarmonicT (SlideT - (DynamicT - (ChordT - StandardPitch))))))))) + (ArticulationT (Sum Double, Sum Double) + (DynamicT (Sum Double) + [Behavior StandardPitch]))))))))) + type StandardPitch = Music.Pitch.Pitch -- data StandardPitch = StandardPitch Music.Pitch.Pitch -- deriving (HasMidi, HasLilypond, HasMusicXml, HasPitch) open = openLilypond . asScore -play = playMidiIO mempty . asScore +play = error "Not implemented: play" openAndPlay x = open x >> play x diff --git a/src/Music/Prelude/StringQuartet.hs b/src/Music/Prelude/StringQuartet.hs deleted file mode 100644 --- a/src/Music/Prelude/StringQuartet.hs +++ /dev/null @@ -1,52 +0,0 @@ - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- A basic music representation for string quartet. --- -------------------------------------------------------------------------------------- -module Music.Prelude.StringQuartet ( - module Music.Score, - StringQuartetPart, - Note, - asScore - ) where - -import Data.AffineSpace.Point -import Data.Typeable -import Music.Dynamics.Literal -import qualified Music.Lilypond as Lilypond -import qualified Music.MusicXml.Simple as Xml -import Music.Pitch -import Music.Score hiding (Interval, Note, Pitch) -import qualified Music.Score as Score - -asScore :: Score Note -> Score Note -asScore = id - -data StringQuartetPart - = Vl1 - | Vl2 - | Vla - | Vc - deriving (Eq, Ord, Enum, Typeable) - -instance Show StringQuartetPart where - show Vl1 = "Violin I" - show Vl2 = "Violin II" - show Vla = "Viola" - show Vc = "Cello" - -type Note = (PartT StringQuartetPart (TieT - (TremoloT (HarmonicT (SlideT - (DynamicT (ArticulationT (TextT Integer)))))))) diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,6 +1,7 @@ module Main where +import System.Exit import Test.Tasty import Test.Tasty.Golden import System.Process @@ -24,7 +25,7 @@ ("tests/golden/" ++ name ++ "." ++ ext) ("tests/current/" ++ name ++ "." ++ ext) ((system $ converter ext ++" -o tests/current/"++name++"."++ext++" tests/"++name++".music") - >> return ()) + >>= \e -> if e == ExitSuccess then return () else fail ("Could not convert "++name++".music")) {- This test will always fail if the test files have been edited. @@ -65,6 +66,7 @@ testMusicFile "dynamics_constant", testMusicFile "melody_chords", testMusicFile "meta_annotations", + testMusicFile "meta_title", testMusicFile "meta_clef1", testMusicFile "meta_composer", testMusicFile "meta_time_signature", diff --git a/tools/music2ly.hs b/tools/music2ly.hs --- a/tools/music2ly.hs +++ b/tools/music2ly.hs @@ -1,8 +1,6 @@ module Main where -import Music.Prelude.CmdLine -import System.Environment +import Music.Prelude.CmdLine -main :: IO () -main = getProgName >>= converterMain "writeLilypond" "ly" +main = converterMain "writeLilypond" "ly" diff --git a/tools/music2midi.hs b/tools/music2midi.hs --- a/tools/music2midi.hs +++ b/tools/music2midi.hs @@ -1,8 +1,6 @@ module Main where -import Music.Prelude.CmdLine -import System.Environment +import Music.Prelude.CmdLine -main :: IO () -main = getProgName >>= converterMain "writeMidi" "mid" +main = converterMain "writeMidi" "mid" diff --git a/tools/music2musicxml.hs b/tools/music2musicxml.hs --- a/tools/music2musicxml.hs +++ b/tools/music2musicxml.hs @@ -1,8 +1,6 @@ module Main where -import Music.Prelude.CmdLine -import System.Environment +import Music.Prelude.CmdLine -main :: IO () -main = getProgName >>= converterMain "writeMusicXml" "xml" +main = converterMain "writeMusicXml" "xml"