{-# LANGUAGE CPP #-}
module Main (main) where
import Control.Applicative ((<|>))
import Control.Monad (forM_, unless, (>=>))
import Data.Char (toLower)
import Data.List (nub, partition, sort)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe,
maybeToList)
import Data.Version (showVersion)
import qualified Paths_jammittools as Paths
import Sound.Jammit.Base
import Sound.Jammit.Export
import qualified System.Console.GetOpt as Opt
import System.Directory (createDirectoryIfMissing)
import qualified System.Environment as Env
import System.Exit (exitFailure)
import System.FilePath (makeValid, takeDirectory, (<.>), (</>))
import Text.PrettyPrint.Boxes (hsep, left, render, text, top, vcat,
(/+/))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
printUsage :: IO ()
printUsage = do
prog <- Env.getProgName
putStrLn $ "jammittools v" ++ showVersion Paths.version
putStrLn ""
let header = "Usage: " ++ prog ++ " -t <title> -r <artist> [options]"
putStr $ Opt.usageInfo header argOpts
putStrLn ""
putStrLn "Instrument parts:"
putStr showCharPartMap
putStrLn "For sheet music, GRBA are tab instead of notation."
putStrLn "For audio, GBDKV are the backing tracks for each instrument."
putStrLn ""
putStrLn "Example usage:"
putStrLn " # Export all sheet music and audio to a new folder"
putStrLn $ " mkdir export; " ++ prog ++ " -t title -r artist -x export"
putStrLn " # Make a sheet music PDF with Guitar 1's notation and tab"
putStrLn $ " " ++ prog ++ " -t title -r artist -y gG -s gtr1.pdf"
putStrLn " # Make an audio track with no drums and no vocals"
putStrLn $ " " ++ prog ++ " -t title -r artist -y D -n vx -a nodrumsvox.wav"
main :: IO ()
main = do
(opts, nonopts, errs) <- Opt.getOpt Opt.Permute argOpts <$> Env.getArgs
unless (null $ nonopts ++ errs) $ do
forM_ nonopts $ \nonopt -> putStrLn $ "unrecognized argument `" ++ nonopt ++ "'"
forM_ errs putStr
printUsage
exitFailure
let args = foldr ($) defaultArgs opts
exportBoth matches dout = do
let sheets = getSheetParts matches
audios = getAudioParts matches
backingOrder = [Drums, Guitar, Keyboard, Bass, Vocal]
isGuitar p = elem (partToInstrument p) [Guitar, Bass]
(gtrs, nongtrs) = partition isGuitar [minBound .. maxBound]
backingTracks = flip mapMaybe backingOrder $ \i ->
case getOneResult (Without i) audios of
Left _ -> Nothing
Right fp -> Just (i, fp)
forM_ gtrs $ \p ->
case (getOneResult (Notation p) sheets, getOneResult (Tab p) sheets) of
(Right note, Right tab) -> let
parts = [note, tab]
systemHeight = sum $ map snd parts
fout = dout </> drop 4 (map toLower $ show p) <.> "pdf"
in do
putStrLn $ "Exporting notation & tab for " ++ show p
runSheet [note, tab] (getPageLines systemHeight args) fout
_ -> return ()
forM_ nongtrs $ \p ->
case getOneResult (Notation p) sheets of
Left _ -> return ()
Right note -> let
fout = dout </> drop 4 (map toLower $ show p) <.> "pdf"
in do
putStrLn $ "Exporting notation for " ++ show p
runSheet [note] (getPageLines (snd note) args) fout
forM_ [minBound .. maxBound] $ \p ->
case getOneResult (Only p) audios of
Left _ -> return ()
Right fp -> let
fout = dout </> drop 4 (map toLower $ show p) <.> "wav"
in do
putStrLn $ "Exporting audio for " ++ show p
runAudio [fp] [] fout
if rawBackings args
then forM_ backingTracks $ \(inst, fback) -> do
putStrLn $ "Exporting backing track for " ++ show inst
let fout = dout </> "backing-" ++ map toLower (show inst) <.> "wav"
runAudio [fback] [] fout
else case backingTracks of
[] -> return ()
(inst, fback) : _ -> let
others = [ fp | (Only p, fp) <- audios, partToInstrument p /= inst ]
fout = dout </> "backing.wav"
in do
putStrLn "Exporting backing audio (could take a while)"
runAudio [fback] others fout
clickTracks <- mapM loadBeats $ map (\(fp, _, _) -> fp) matches
case catMaybes clickTracks of
[] -> return ()
beats : _ -> do
putStrLn "Exporting metronome click track"
writeMetronomeTrack (dout </> "click.wav") beats
case function args of
PrintUsage -> printUsage
ShowDatabase -> do
matches <- searchResults args
putStr $ showLibrary matches
ExportAudio fout -> do
matches <- getAudioParts <$> searchResultsChecked args
let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart
case (f $ selectParts args, f $ rejectParts args) of
(Left err , _ ) -> error err
(_ , Left err ) -> error err
(Right yaifcs, Right naifcs) -> runAudio yaifcs naifcs fout
ExportClick fout -> do
matches <- map (\(fp, _, _) -> fp) <$> searchResultsChecked args
clickTracks <- mapM loadBeats matches
case catMaybes clickTracks of
[] -> do
putStrLn $ "Couldn't load beats.plist from any of these folders: " ++ show matches
exitFailure
beats : _ -> writeMetronomeTrack fout beats
CheckPresence -> do
matches <- getAudioParts <$> searchResultsChecked args
let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart
case (f $ selectParts args, f $ rejectParts args) of
(Left err , _ ) -> error err
(_ , Left err ) -> error err
(Right _ , Right _ ) -> return ()
ExportSheet fout -> do
matches <- getSheetParts <$> searchResultsChecked args
let f = mapM (`getOneResult` matches) . mapMaybe charToSheetPart
case f $ selectParts args of
Left err -> error err
Right parts -> let
systemHeight = sum $ map snd parts
in runSheet parts (getPageLines systemHeight args) fout
ExportAll dout -> do
matches <- searchResultsChecked args
exportBoth matches dout
ExportLib dout -> do
matches <- searchResults args
let titleArtists = nub [ (title info, artist info) | (_, info, _) <- matches ]
forM_ titleArtists $ \ta@(t, a) -> do
putStrLn $ "# SONG: " ++ a ++ " - " ++ t
let entries = filter (\(_, info, _) -> ta == (title info, artist info)) matches
songDir = dout </> makeValid (removeSlashes $ a ++ " - " ++ t)
removeSlashes = map $ \c -> case c of '/' -> '_'; '\\' -> '_'; _ -> c
createDirectoryIfMissing False songDir
exportBoth entries songDir
getPageLines :: Integer -> Args -> Int
getPageLines systemHeight args = let
pageHeight = sheetWidth / 8.5 * 11 :: Double
defaultLines = round $ pageHeight / fromIntegral systemHeight
in max 1 $ fromMaybe defaultLines $ pageLines args
-- | If there is exactly one pair with the given first element, returns its
-- second element. Otherwise (for 0 or >1 elements) returns an error.
getOneResult :: (Eq a, Show a) => a -> [(a, b)] -> Either String b
getOneResult x xys = case [ b | (a, b) <- xys, a == x ] of
[y] -> Right y
[] -> Left $ "Couldn't find the part " ++ show x
ys -> Left $ unwords
[ "Found"
, show $ length ys
, "different parts for"
, show x ++ ";"
, "this is probably a bug?"
]
-- | Displays a table of the library, possibly filtered by search terms.
showLibrary :: Library -> String
showLibrary lib = let
titleArtists = sort $ nub [ (title info, artist info) | (_, info, _) <- lib ]
partsFor ttl art = map partToChar $ sort $ concat
[ mapMaybe (trackTitle >=> titleToPart) trks
| (_, info, trks) <- lib
, (ttl, art) == (title info, artist info) ]
makeColumn h col = text h /+/ vcat left (map text col)
titleColumn = makeColumn "Title" $ map fst titleArtists
artistColumn = makeColumn "Artist" $ map snd titleArtists
partsColumn = makeColumn "Parts" $ map (uncurry partsFor) titleArtists
in render $ hsep 1 top [titleColumn, artistColumn, partsColumn]
-- | Loads the Jammit library, and applies the search terms from the arguments
-- to filter it.
searchResults :: Args -> IO Library
searchResults args = do
exeDir <- takeDirectory <$> Env.getExecutablePath
jmt <- case jammitDir args of
Just j -> return [j]
Nothing -> Env.lookupEnv "JAMMIT" >>= \mv -> case mv of
Just j -> return [j]
Nothing -> maybeToList <$> findJammitDir
db <- concat <$> mapM loadLibrary (exeDir : jmt)
return $ filterLibrary args db
-- | Checks that the search actually narrowed down the library to a single song.
searchResultsChecked :: Args -> IO Library
searchResultsChecked args = do
lib <- searchResults args
case [ info | (_, info, _) <- lib ] of
[] -> do
putStrLn "No songs matched your search."
exitFailure
x : xs -> if all (\y -> title y == title x && artist y == artist x) xs
then return lib
else do
putStrLn "Multiple songs matched your search:"
putStr $ showLibrary lib
exitFailure
argOpts :: [Opt.OptDescr (Args -> Args)]
argOpts =
[ Opt.Option ['t'] ["title"]
(Opt.ReqArg
(\s a -> a { filterLibrary = fuzzySearchBy title s . filterLibrary a })
"str")
"search by song title (fuzzy)"
, Opt.Option ['r'] ["artist"]
(Opt.ReqArg
(\s a -> a { filterLibrary = fuzzySearchBy artist s . filterLibrary a })
"str")
"search by song artist (fuzzy)"
, Opt.Option ['T'] ["title-exact"]
(Opt.ReqArg
(\s a -> a { filterLibrary = exactSearchBy title s . filterLibrary a })
"str")
"search by song title (exact)"
, Opt.Option ['R'] ["artist-exact"]
(Opt.ReqArg
(\s a -> a { filterLibrary = exactSearchBy artist s . filterLibrary a })
"str")
"search by song artist (exact)"
, Opt.Option ['y'] ["yes-parts"]
(Opt.ReqArg (\s a -> a { selectParts = s }) "parts")
"parts to appear in sheet music or audio"
, Opt.Option ['n'] ["no-parts"]
(Opt.ReqArg (\s a -> a { rejectParts = s }) "parts")
"parts to subtract (add inverted) from audio"
, Opt.Option ['l'] ["lines"]
(Opt.ReqArg (\s a -> a { pageLines = Just $ read s }) "int")
"number of systems per page"
, Opt.Option ['j'] ["jammit"]
(Opt.ReqArg (\s a -> a { jammitDir = Just s }) "directory")
"location of Jammit library"
, Opt.Option ['?', 'h'] ["help"]
(Opt.NoArg $ \a -> a { function = PrintUsage })
"function: print usage info"
, Opt.Option ['d'] ["database"]
(Opt.NoArg $ \a -> a { function = ShowDatabase })
"function: display all songs in db"
, Opt.Option ['s'] ["sheet"]
(Opt.ReqArg (\s a -> a { function = ExportSheet s }) "file")
"function: export sheet music"
, Opt.Option ['a'] ["audio"]
(Opt.ReqArg (\s a -> a { function = ExportAudio s }) "file")
"function: export audio"
, Opt.Option ['m'] ["metronome"]
(Opt.ReqArg (\s a -> a { function = ExportClick s }) "file")
"function: export metronome audio"
, Opt.Option ['x'] ["export"]
(Opt.ReqArg (\s a -> a { function = ExportAll s }) "dir")
"function: export song to dir"
, Opt.Option ['b'] ["backup"]
(Opt.ReqArg (\s a -> a { function = ExportLib s }) "dir")
"function: export library to dir"
, Opt.Option ['c'] ["check"]
(Opt.NoArg $ \a -> a { function = CheckPresence })
"function: check presence of audio parts"
, Opt.Option [] ["raw"]
(Opt.NoArg $ \a -> a { rawBackings = True })
"when exporting song/library, extract all individual backing tracks"
]
data Args = Args
{ filterLibrary :: Library -> Library
, selectParts :: String
, rejectParts :: String
, pageLines :: Maybe Int
, jammitDir :: Maybe FilePath
, function :: Function
, rawBackings :: Bool
}
data Function
= PrintUsage
| ShowDatabase
| ExportSheet FilePath
| ExportAudio FilePath
| ExportClick FilePath
| ExportAll FilePath
| ExportLib FilePath
| CheckPresence
deriving (Eq, Ord, Show, Read)
defaultArgs :: Args
defaultArgs = Args
{ filterLibrary = id
, selectParts = ""
, rejectParts = ""
, pageLines = Nothing
, jammitDir = Nothing
, function = PrintUsage
, rawBackings = False
}
partToChar :: Part -> Char
partToChar p = case p of
PartGuitar1 -> 'g'
PartGuitar2 -> 'r'
PartBass1 -> 'b'
PartBass2 -> 'a'
PartDrums1 -> 'd'
PartDrums2 -> 'm'
PartKeys1 -> 'k'
PartKeys2 -> 'y'
PartPiano -> 'p'
PartSynth -> 's'
PartOrgan -> 'o'
PartVocal -> 'v'
PartBVocals -> 'x'
charPartMap :: [(Char, Part)]
charPartMap = [ (partToChar p, p) | p <- [minBound .. maxBound] ]
showCharPartMap :: String
showCharPartMap = let
len = ceiling (fromIntegral (length charPartMap) / 2 :: Double)
(map1, map2) = splitAt len charPartMap
col1 = vcat left [ text $ [c] ++ ": " ++ drop 4 (show p) | (c, p) <- map1 ]
col2 = vcat left [ text $ [c] ++ ": " ++ drop 4 (show p) | (c, p) <- map2 ]
in render $ hsep 2 top [text "", col1, col2]
charToSheetPart :: Char -> Maybe SheetPart
charToSheetPart c = let
notation = Notation <$> lookup c charPartMap
tab = Tab <$> lookup (toLower c) charPartMap
in notation <|> tab
charToAudioPart :: Char -> Maybe AudioPart
charToAudioPart c = let
only = Only <$> lookup c charPartMap
without = Without . partToInstrument <$> lookup (toLower c) charPartMap
in only <|> without