-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Functions to parse MIDI patch files.
module Instrument.Parse where
import qualified Control.Monad.State.Strict as State
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe

import qualified Util.P as P
import           Util.P ((<?>))
import qualified Util.Parse as Parse

import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Sysex as Sysex
import qualified Instrument.Tag as Tag

import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import qualified Ui.Id as Id

import           Global


type Parser st a = Parse.ParserS st a

-- * annotation file

type Annotation = Tag.Tag

-- | Format is @synth\/inst-name tag1=x tag2=y@.
--
-- TODO other attributes are not supported, but if there were, they could look
-- like @*pb-range=12 *flag=pressure@
parse_annotations :: FilePath
    -> IO (Either String (Map InstT.Qualified [Annotation]))
parse_annotations :: FilePath -> IO (Either FilePath (Map Qualified [Annotation]))
parse_annotations FilePath
fn = do
    Either Text [(Qualified, [Annotation])]
result <- forall a st.
a -> ParserS st a -> st -> FilePath -> IO (Either Text a)
Parse.file forall a. Monoid a => a
mempty forall st. Parser st [(Qualified, [Annotation])]
p_annotation_file () FilePath
fn
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Show a => a -> FilePath
show (forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)) Either Text [(Qualified, [Annotation])]
result

p_annotation_file :: Parser st [(InstT.Qualified, [Annotation])]
p_annotation_file :: forall st. Parser st [(Qualified, [Annotation])]
p_annotation_file = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many forall st. Parser st [(Qualified, [Annotation])]
line forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
    where line :: ParsecT Void Text (StateT st Identity) [(Qualified, [Annotation])]
line = ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try forall st. Parser st (Qualified, [Annotation])
p_annotation_line) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall st. Parser st ()
p_eol forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [])

p_annotation_line :: Parser st (InstT.Qualified, [Annotation])
p_annotation_line :: forall st. Parser st (Qualified, [Annotation])
p_annotation_line =
    ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st a. Parser st a -> Parser st a
lexeme forall st. Parser st Qualified
p_qualified forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (forall st a. Parser st a -> Parser st a
lexeme forall st. Parser st Annotation
p_tag)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. Parser st ()
p_eol

p_qualified :: Parser st InstT.Qualified
p_qualified :: forall st. Parser st Qualified
p_qualified =
    Text -> Text -> Qualified
InstT.Qualified forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text (StateT st Identity) (Tokens Text)
chars forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text (StateT st Identity) (Tokens Text)
chars) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"qualified"
    where chars :: ParsecT Void Text (StateT st Identity) (Tokens Text)
chars = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
Id.is_id_char

p_tag :: Parser st Tag.Tag
p_tag :: forall st. Parser st Annotation
p_tag =
    (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
tag_char
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Text
"" (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
tag_char)
    where tag_char :: Char -> Bool
tag_char Char
c = Char -> Bool
Char.isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'

lexeme :: Parser st a -> Parser st a
lexeme :: forall st a. Parser st a -> Parser st a
lexeme Parser st a
p = Parser st a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. Parser st ()
p_whitespace

p_eol :: Parser st ()
p_eol :: forall st. Parser st ()
p_eol = forall st. Parser st ()
p_whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'\n'

p_whitespace :: Parser st ()
p_whitespace :: forall st. Parser st ()
p_whitespace = forall (m :: * -> *) a. MonadPlus m => m a -> m ()
P.skipMany (forall e (m :: * -> *). Ord e => FilePath -> ParsecT e Text m Char
P.oneOfC FilePath
" \t") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option () ParsecT Void Text (StateT st Identity) ()
comment
    where comment :: ParsecT Void Text (StateT st Identity) ()
comment = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'#' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadPlus m => m a -> m ()
P.skipMany (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (forall a. Eq a => a -> a -> Bool
/=Char
'\n'))


-- * patch file

{- | Parse a simple ad-hoc text file format to describe a synth's built-in
    patches.

    Each line should look like @inst-name, tag=val, tag=val, ...@.
    The instrument name can contain any character except a comma, but the
    tags are restricted to [a-z0-9-].  The @category@ tag is treated specially:
    if not set it will be inherited from the previous category.

    The patch's program change is incremented for each patch.  A line like
    @*bank <num>@ sets the bank number and resets the program change to 0.

    Comments start with @#@, and blank lines are ignored.
-}
patch_file :: FilePath -> IO [Sysex.Patch]
patch_file :: FilePath -> IO [(Patch, Common ())]
patch_file FilePath
fn = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"parse patches: " <>)) forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Either Text [(Patch, Common ())])
parse_patch_file FilePath
fn

parse_patch_file :: String -> IO (Either Text [Sysex.Patch])
parse_patch_file :: FilePath -> IO (Either Text [(Patch, Common ())])
parse_patch_file FilePath
fn =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. FilePath -> Common a -> Common a
Sysex.add_file FilePath
fn))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a st.
a -> ParserS st a -> st -> FilePath -> IO (Either Text a)
Parse.file forall a. Monoid a => a
mempty Parser State [(Patch, Common ())]
p_patch_file State
empty_state FilePath
fn

data State = State {
    State -> Int
state_bank :: Int
    , State -> Program
state_patch_num :: Midi.Program
    } deriving (Int -> State -> ShowS
[State] -> ShowS
State -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> FilePath
$cshow :: State -> FilePath
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

empty_state :: State
empty_state :: State
empty_state = Int -> Program -> State
State Int
0 Program
0

data PatchLine = PatchLine {
    PatchLine -> Text
patch_name :: Text
    , PatchLine -> Int
patch_bank :: Int
    , PatchLine -> Program
patch_program :: Midi.Program
    , PatchLine -> [Annotation]
patch_tags :: [Tag.Tag]
    } deriving (Int -> PatchLine -> ShowS
[PatchLine] -> ShowS
PatchLine -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PatchLine] -> ShowS
$cshowList :: [PatchLine] -> ShowS
show :: PatchLine -> FilePath
$cshow :: PatchLine -> FilePath
showsPrec :: Int -> PatchLine -> ShowS
$cshowsPrec :: Int -> PatchLine -> ShowS
Show)

p_patch_file :: Parser State [Sysex.Patch]
p_patch_file :: Parser State [(Patch, Common ())]
p_patch_file = do
    [PatchLine]
patches <- forall a. [Maybe a] -> [a]
Maybe.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many Parser State (Maybe PatchLine)
p_line
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PbRange -> PatchLine -> (Patch, Common ())
make_patch (-Int
2, Int
2)) ([PatchLine] -> [PatchLine]
inherit_prev_category [PatchLine]
patches)
    where
    inherit_prev_category :: [PatchLine] -> [PatchLine]
inherit_prev_category = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Maybe Text -> PatchLine -> (Maybe Text, PatchLine)
inherit forall a. Maybe a
Nothing
    inherit :: Maybe Text -> PatchLine -> (Maybe Text, PatchLine)
inherit Maybe Text
maybe_prev PatchLine
patch = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
Tag.category [Annotation]
tags of
            Maybe Text
Nothing -> case Maybe Text
maybe_prev of
                Maybe Text
Nothing -> (forall a. Maybe a
Nothing, PatchLine
patch)
                Just Text
prev -> (forall a. a -> Maybe a
Just Text
prev,
                    PatchLine
patch { patch_tags :: [Annotation]
patch_tags = (Text
Tag.category, Text
prev) forall a. a -> [a] -> [a]
: [Annotation]
tags })
            Just Text
cat -> (forall a. a -> Maybe a
Just Text
cat, PatchLine
patch)
        where tags :: [Annotation]
tags = PatchLine -> [Annotation]
patch_tags PatchLine
patch

make_patch :: Control.PbRange -> PatchLine -> Sysex.Patch
make_patch :: PbRange -> PatchLine -> (Patch, Common ())
make_patch PbRange
pb_range (PatchLine Text
name Int
bank Program
patch_num [Annotation]
tags) = (Patch
patch, Common ()
common)
    where
    patch :: Patch
patch = (PbRange -> Text -> Patch
Patch.patch PbRange
pb_range Text
name)
        { patch_initialize :: InitializePatch
Patch.patch_initialize =
            [ChannelMessage] -> InitializePatch
Patch.initialize_midi forall a b. (a -> b) -> a -> b
$ Int -> Program -> [ChannelMessage]
Midi.program_change Int
bank Program
patch_num
        }
    common :: Common ()
common = (forall code. code -> Common code
Common.common ()) { common_tags :: [Annotation]
Common.common_tags = [Annotation]
tags }

p_line :: Parser State (Maybe PatchLine)
p_line :: Parser State (Maybe PatchLine)
p_line =
    (Parser State ()
p_bank_decl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall st. Parser st ()
p_eol forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just Parser State PatchLine
p_patch_line

p_patch_line :: Parser State PatchLine
p_patch_line :: Parser State PatchLine
p_patch_line = do
    Text
name <- forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'\n', Char
','])
    [Annotation]
tags <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option [] forall a b. (a -> b) -> a -> b
$ forall {st}. Parser st Char
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy1 forall st. Parser st Annotation
p_tag forall {st}. Parser st Char
comma
    forall st. Parser st ()
p_eol
    State
st <- forall s (m :: * -> *). MonadState s m => m s
State.get
    forall s (m :: * -> *). MonadState s m => s -> m ()
State.put forall a b. (a -> b) -> a -> b
$ State
st { state_patch_num :: Program
state_patch_num = State -> Program
state_patch_num State
st forall a. Num a => a -> a -> a
+ Program
1 }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Int -> Program -> [Annotation] -> PatchLine
PatchLine Text
name (State -> Int
state_bank State
st) (State -> Program
state_patch_num State
st) [Annotation]
tags
    where
    comma :: Parser st (Token Text)
comma = forall st a. Parser st a -> Parser st a
lexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
',')

p_bank_decl :: Parser State ()
p_bank_decl :: Parser State ()
p_bank_decl = do
    forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Tokens Text
"*bank"
    forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
P.space1
    Int
n <- forall (m :: * -> *). ParserT m Int
Parse.p_nat
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_bank :: Int
state_bank = Int
n, state_patch_num :: Program
state_patch_num = Program
0 }