{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, ConstraintKinds, FlexibleContexts #-} module Music.Score.Import.Sibelius ( IsSibelius(..), fromSibelius, readSibelius, readSibeliusMaybe, readSibeliusEither ) where import Control.Lens import Music.Sibelius import Music.Score import Data.Aeson import Music.Pitch.Literal (IsPitch) import qualified Music.Pitch.Literal as Pitch import qualified Data.ByteString.Lazy as ByteString -- | -- Convert a score from a Sibelius representation. -- fromSibelius :: IsSibelius a => SibeliusScore -> Score a fromSibelius (SibeliusScore title composer info staffH transp staves systemStaff) = foldr () mempty $ fmap fromSibeliusStaff staves -- TODO meta information fromSibeliusStaff :: IsSibelius a => SibeliusStaff -> Score a fromSibeliusStaff (SibeliusStaff bars name shortName) = removeRests $ scat $ fmap fromSibeliusBar bars -- TODO bar length hardcoded -- TODO meta information -- NOTE slur pos/dur always "stick" to an adjacent note, regardless of visual position -- for other lines (cresc etc) this might not be the case -- WARNING key sig changes goes at end of previous bar fromSibeliusBar :: IsSibelius a => SibeliusBar -> Score (Maybe a) fromSibeliusBar (SibeliusBar elems) = fmap Just (pcat $ fmap fromSibeliusChordElem chords) <> return Nothing^*1 where chords = filter isChord elems tuplets = filter isTuplet elems -- TODO use these floating = filter isFloating elems fromSibeliusChordElem :: IsSibelius a => SibeliusBarObject -> Score a fromSibeliusChordElem = go where go (SibeliusBarObjectChord chord) = fromSibeliusChord chord go _ = error "fromSibeliusChordElem: Expected chord" -- handleFloatingElem :: IsSibelius a => SibeliusBarObject -> [Score a] -> [Score a] isChord (SibeliusBarObjectChord _) = True isChord _ = False isTuplet (SibeliusBarObjectTuplet _) = True isTuplet _ = False isFloating x = not (isChord x) && not (isTuplet x) fromSibeliusChord :: IsSibelius a => SibeliusChord -> Score a fromSibeliusChord (SibeliusChord pos dur voice ar strem dtrem acci appo notes) = showVals $ setTime $ setDur $ every setArt ar $ tremolo strem $ pcat $ fmap fromSibeliusNote notes where showVals = text (show pos ++ " " ++ show dur) -- TODO DEBUG -- WARNING for tuplets, positions are absolute (sounding), but durations are relative (written) -- To retrieve sounding duration we must find floating tuplet objects and use -- the duration/playedDuration fields setTime = delay (fromIntegral pos / kTicksPerWholeNote) setDur = stretch (fromIntegral dur / kTicksPerWholeNote) setArt Marcato = marcato setArt Accent = accent setArt Tenuto = tenuto setArt Staccato = staccato setArt a = error $ "fromSibeliusChord: Unsupported articulation" ++ show a -- TODO tremolo and appogiatura/acciaccatura support fromSibeliusNote :: IsSibelius a => SibeliusNote -> Score a fromSibeliusNote (SibeliusNote pitch diatonicPitch acc tied style) = (if tied then fmap beginTie else id) $ fmap (up' (fromIntegral pitch - 60)) Pitch.c -- TODO spell correctly if this is Common.Pitch (how to distinguish) where up' x = pitch' %~ (+ x) -- up' x = mapPitch' (+ x) -- | -- Read a Sibelius score from a file. Fails if the file could not be read or if a parsing -- error occurs. -- readSibelius :: IsSibelius a => FilePath -> IO (Score a) readSibelius path = fmap (either (\x -> error $ "Could not read score " ++ x) id) $ readSibeliusEither path -- | -- Read a Sibelius score from a file. Fails if the file could not be read, and returns -- @Nothing@ if a parsing error occurs. -- readSibeliusMaybe :: IsSibelius a => FilePath -> IO (Maybe (Score a)) readSibeliusMaybe path = fmap (either (const Nothing) Just) $ readSibeliusEither path -- | -- Read a Sibelius score from a file. Fails if the file could not be read, and returns -- @Left m@ if a parsing error occurs. -- readSibeliusEither :: IsSibelius a => FilePath -> IO (Either String (Score a)) readSibeliusEither path = do json <- ByteString.readFile path return $ fmap fromSibelius $ eitherDecode' json -- | -- This constraint includes all note types that can be constructed from a Sibelius representation. -- type IsSibelius a = ( IsPitch a, HasPart' a, Enum (Part a), HasPitch' a, Num (Pitch a), HasTremolo a, HasArticulation a, HasText a, Tiable a ) -- Util every :: (a -> b -> b) -> [a] -> b -> b every f = flip (foldr f) kTicksPerWholeNote = 1024 -- Always in Sibelius