-- | Generates module 'GeneralMidi'
import Data.Char
import Data.List.Split
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.Build'
import qualified Text.PrettyPrint as P
toFunName :: String -> String
toFunName x = map toLower pref ++ suff
where pref = takeWhile isUpper x
suff = dropWhile isUpper x
-- module
moduleGM name instrs drums = P.vcat $ P.punctuate wspace [
P.text "-- | General MIDI names",
moduleHead name instrs drums,
imports,
division "Instruments",
pp $ instrSig instrs,
P.vcat $ map pp $ instrFuns instrs,
division "Percussion",
pp $ drumSig drums,
P.vcat $ map pp $ drumFuns drums]
where pp = P.text . prettyPrint
wspace = P.text "\n\n"
division x = (P.text $ replicate 20 '-')
P.$$ (P.text $ "--" ++ x)
moduleHead name instrs drums = P.vcat [
P.text $ "module " ++ name ++ "(",
P.nest 4 $ exports instrs drums P.<> P.rparen,
P.text "where"]
exports instrs drums =
P.vcat [
P.text (toSec1 "Instruments"),
P.vcat $ map ( P.<> P.comma) $
map (uncurry expFunNames) $
expInstrFunNames (map toSec2 familyNames) instrs,
P.text "\n\n",
expFunNames (toSec1 "Percussion") drums]
toSec1 = ("-- * " ++ )
toSec2 = ("-- ** " ++)
expInstrFunNames fams names = zip fams $ splitEvery 8 names
expFunNames :: String -> [String] -> P.Doc
expFunNames sec names = (P.text sec P.$$ ) $ P.vcat $
P.punctuate P.comma $ map P.text names
imports :: P.Doc
imports = P.vcat [
P.text "import Temporal.Music.Notation(Score, Seg)",
P.text "import Temporal.Music.Notation.Note(Note, Drum)",
P.text "import Temporal.Music.Notation.Demo"]
-- instruments
zSrcLoc = SrcLoc "" 0 0
instrSig :: [String] -> Decl
instrSig xs = typeSig zSrcLoc xs $
[var "Seg" "nVol", var "Seg" "nPch"]
=>> var "Score" <$> var "Note" `apps` [var "nVol", var "nPch", var "a"]
->> var "Score" <$> var "MidiEvent"
instrFuns = toFuns 0 "instr"
-- drums
drumSig :: [String] -> Decl
drumSig xs = typeSig zSrcLoc xs $
[var "Seg" "nVol"]
=>> var "Score" <$> var "Drum" `apps` [var "nVol", var "a"]
->> var "Score" <$> var "MidiEvent"
drumFuns = toFuns 35 "drumInstr"
-- funs
toFuns :: Integer -> String -> [String] -> [Decl]
toFuns i0 constr = map (uncurry $ toFun constr) . zip [i0 .. ]
toFun :: String -> Integer -> String -> Decl
toFun constr id name = fun zSrcLoc name [] <=> (var constr <$> int id)
out :: Pretty a => a -> IO ()
out = putStrLn . prettyPrint
main = do
let i = map (toFunName . show) $ [(minBound :: InstrumentName) .. maxBound]
d = map (toFunName . show) $ [(minBound :: PercussionName) .. maxBound]
writeFile "GeneralMidi.hs" $ show $
moduleGM "Temporal.Music.Notation.Demo.GeneralMidi" i d
familyNames :: [String]
familyNames = map (splitAtUpper . show)
[(minBound :: InstrumentFamily) .. maxBound]
where splitAtUpper = unwords . split (keepDelimsL $ whenElt isUpper)
data InstrumentFamily =
Piano | ChromaticPercussion | Organ | Guitar
| Bass | Strings | Ensemble | Brass
| Reed | Pipe | SynthLead | SynthPad
| SynthEffects | Ethnic | Percussive | SoundEffects
deriving (Show, Enum, Bounded)
data InstrumentName =
AcousticGrandPiano | BrightAcousticPiano | ElectricGrandPiano
| HonkyTonkPiano | RhodesPiano | ChorusedPiano
| Harpsichord | Clavinet | Celesta
| Glockenspiel | MusicBox | Vibraphone
| Marimba | Xylophone | TubularBells
| Dulcimer | HammondOrgan | PercussiveOrgan
| RockOrgan | ChurchOrgan | ReedOrgan
| Accordion | Harmonica | TangoAccordion
| AcousticGuitarNylon | AcousticGuitarSteel | ElectricGuitarJazz
| ElectricGuitarClean | ElectricGuitarMuted | OverdrivenGuitar
| DistortionGuitar | GuitarHarmonics | AcousticBass
| ElectricBassFingered | ElectricBassPicked | FretlessBass
| SlapBass1 | SlapBass2 | SynthBass1
| SynthBass2 | Violin | Viola
| Cello | Contrabass | TremoloStrings
| PizzicatoStrings | OrchestralHarp | Timpani
| StringEnsemble1 | StringEnsemble2 | SynthStrings1
| SynthStrings2 | ChoirAahs | VoiceOohs
| SynthVoice | OrchestraHit | Trumpet
| Trombone | Tuba | MutedTrumpet
| FrenchHorn | BrassSection | SynthBrass1
| SynthBrass2 | SopranoSax | AltoSax
| TenorSax | BaritoneSax | Oboe
| Bassoon | EnglishHorn | Clarinet
| Piccolo | Flute | Recorder
| PanFlute | BlownBottle | Shakuhachi
| Whistle | Ocarina | Lead1Square
| Lead2Sawtooth | Lead3Calliope | Lead4Chiff
| Lead5Charang | Lead6Voice | Lead7Fifths
| Lead8BassLead | Pad1NewAge | Pad2Warm
| Pad3Polysynth | Pad4Choir | Pad5Bowed
| Pad6Metallic | Pad7Halo | Pad8Sweep
| FX1Train | FX2Soundtrack | FX3Crystal
| FX4Atmosphere | FX5Brightness | FX6Goblins
| FX7Echoes | FX8SciFi | Sitar
| Banjo | Shamisen | Koto
| Kalimba | Bagpipe | Fiddle
| Shanai | TinkleBell | Agogo
| SteelDrums | Woodblock | TaikoDrum
| MelodicDrum | SynthDrum | ReverseCymbal
| GuitarFretNoise | BreathNoise | Seashore
| BirdTweet | TelephoneRing | Helicopter
| Applause | Gunshot
deriving (Show, Enum, Bounded)
data PercussionName =
AcousticBassDrum | BassDrum1 | SideStick
| AcousticSnare | HandClap | ElectricSnare
| LowFloorTom | ClosedHiHat | HighFloorTom
| PedalHiHat | LowTom | OpenHiHat
| LowMidTom | HiMidTom | CrashCymbal1
| HighTom | RideCymbal1 | ChineseCymbal
| RideBell | Tambourine | SplashCymbal
| Cowbell | CrashCymbal2 | Vibraslap
| RideCymbal2 | HiBongo | LowBongo
| MuteHiConga | OpenHiConga | LowConga
| HighTimbale | LowTimbale | HighAgogo
| LowAgogo | Cabasa | Maracas
| ShortWhistle | LongWhistle | ShortGuiro
| LongGuiro | Claves | HiWoodBlock
| LowWoodBlock | MuteCuica | OpenCuica
| MuteTriangle | OpenTriangle
deriving (Show, Enum, Bounded)