module Sound.MIDI.MachineControl (
splitCommandList,
getCommand,
getCommands,
Command (
Stop,
Play,
DeferredPlay,
FastForward,
Rewind,
RecordStrobe,
RecordExit,
RecordPause,
Pause,
Eject,
Chase,
CommandErrorReset,
Reset,
Wait,
Resume
),
runParser,
) where
import Sound.MIDI.Parser.Primitive
import qualified Sound.MIDI.Parser.Class as Parser
import qualified Sound.MIDI.Parser.Stream as SP
import Sound.MIDI.IO (ByteList, )
import qualified Numeric.NonNegative.Wrapper as NonNeg
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.State as MS
import Control.Monad (liftM, liftM2, liftM3, )
import Data.List (unfoldr, )
import Data.Tuple.HT (mapFst, )
import Data.Bool.HT (if', )
import Data.Word (Word8, )
import Data.Maybe (isNothing, catMaybes, )
splitCommandList :: [Word8] -> [(Word8, [Word8])]
splitCommandList :: [Word8] -> [(Word8, [Word8])]
splitCommandList =
([Word8] -> Maybe ((Word8, [Word8]), [Word8]))
-> [Word8] -> [(Word8, [Word8])]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([Word8] -> Maybe ((Word8, [Word8]), [Word8]))
-> [Word8] -> [(Word8, [Word8])])
-> ([Word8] -> Maybe ((Word8, [Word8]), [Word8]))
-> [Word8]
-> [(Word8, [Word8])]
forall a b. (a -> b) -> a -> b
$ \[Word8]
xt ->
case [Word8]
xt of
[] -> Maybe ((Word8, [Word8]), [Word8])
forall a. Maybe a
Nothing
Word8
x:[Word8]
xs ->
((Word8, [Word8]), [Word8]) -> Maybe ((Word8, [Word8]), [Word8])
forall a. a -> Maybe a
Just (((Word8, [Word8]), [Word8]) -> Maybe ((Word8, [Word8]), [Word8]))
-> ((Word8, [Word8]), [Word8]) -> Maybe ((Word8, [Word8]), [Word8])
forall a b. (a -> b) -> a -> b
$ (([Word8] -> (Word8, [Word8]))
-> ([Word8], [Word8]) -> ((Word8, [Word8]), [Word8])
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((,) Word8
x)) (([Word8], [Word8]) -> ((Word8, [Word8]), [Word8]))
-> ([Word8], [Word8]) -> ((Word8, [Word8]), [Word8])
forall a b. (a -> b) -> a -> b
$
Bool
-> ([Word8], [Word8]) -> ([Word8], [Word8]) -> ([Word8], [Word8])
forall a. Bool -> a -> a -> a
if' (Word8
xWord8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
0 Bool -> Bool -> Bool
|| Word8
xWord8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
0xF7) ([Word8]
xs, []) (([Word8], [Word8]) -> ([Word8], [Word8]))
-> ([Word8], [Word8]) -> ([Word8], [Word8])
forall a b. (a -> b) -> a -> b
$
Bool
-> ([Word8], [Word8]) -> ([Word8], [Word8]) -> ([Word8], [Word8])
forall a. Bool -> a -> a -> a
if' (Word8
0x40 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x78)
(case [Word8]
xs of
[] -> ([], [])
Word8
n:[Word8]
ys -> Int -> [Word8] -> ([Word8], [Word8])
forall a. Int -> [a] -> ([a], [a])
splitAt (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) [Word8]
ys) (([Word8], [Word8]) -> ([Word8], [Word8]))
-> ([Word8], [Word8]) -> ([Word8], [Word8])
forall a b. (a -> b) -> a -> b
$
([], [Word8]
xs)
data Command =
Stop
| Play
| DeferredPlay
| FastForward
| Rewind
| RecordStrobe
| RecordExit
| RecordPause
| Pause
| Eject
| Chase
| CommandErrorReset
| Reset
| Write ByteList
| MaskedWrite ByteList
| Read ByteList
| Update ByteList
| Locate ByteList
| VariablePlay Word8 Word8 Word8
| Search Word8 Word8 Word8
| Shuttle Word8 Word8 Word8
| Step Word8
| AssignSystemMaster Word8
| GeneratorCommand Word8
| MIDITimeCodeCommand Word8
| Move Word8 Word8
| Add Word8 Word8 Word8
| Subtract Word8 Word8 Word8
| DropFrameAdjust Word8
| Procedure ByteList
| Event ByteList
| Group ByteList
| CommandSegment ByteList
| DeferredVariablePlay ByteList
| RecordStrobeVariable ByteList
| Wait
| Resume
| GenericNoData Word8
| GenericVariableLength Word8 ByteList
deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)
getCommands :: Parser.C parser => Parser.Partial parser [Command]
getCommands :: Partial parser [Command]
getCommands =
(Exceptional String [Maybe Command]
-> Exceptional String [Command])
-> parser (Exceptional String [Maybe Command])
-> Partial parser [Command]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([Maybe Command] -> [Command])
-> Exceptional String [Maybe Command]
-> Exceptional String [Command]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Command] -> [Command]
forall a. [Maybe a] -> [a]
catMaybes) (parser (Exceptional String [Maybe Command])
-> Partial parser [Command])
-> parser (Exceptional String [Maybe Command])
-> Partial parser [Command]
forall a b. (a -> b) -> a -> b
$
(Maybe Command -> Bool)
-> Fragile parser (Maybe Command)
-> parser (Exceptional String [Maybe Command])
forall (parser :: * -> *) a.
EndCheck parser =>
(a -> Bool) -> Fragile parser a -> Partial parser [a]
Parser.until Maybe Command -> Bool
forall a. Maybe a -> Bool
isNothing (Fragile parser (Maybe Command)
-> parser (Exceptional String [Maybe Command]))
-> Fragile parser (Maybe Command)
-> parser (Exceptional String [Maybe Command])
forall a b. (a -> b) -> a -> b
$ do
Word8
code <- Fragile parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte
if Word8
code Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xF7
then Maybe Command -> Fragile parser (Maybe Command)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Command
forall a. Maybe a
Nothing
else (Command -> Maybe Command)
-> ExceptionalT String parser Command
-> Fragile parser (Maybe Command)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Command -> Maybe Command
forall a. a -> Maybe a
Just (ExceptionalT String parser Command
-> Fragile parser (Maybe Command))
-> ExceptionalT String parser Command
-> Fragile parser (Maybe Command)
forall a b. (a -> b) -> a -> b
$ Word8 -> ExceptionalT String parser Command
forall (parser :: * -> *).
C parser =>
Word8 -> Fragile parser Command
getCommand Word8
code
getCommand :: Parser.C parser => Word8 -> Parser.Fragile parser Command
getCommand :: Word8 -> Fragile parser Command
getCommand Word8
code =
let fetchMany :: ([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> r
f = ([Word8] -> r)
-> ExceptionalT String parser [Word8]
-> ExceptionalT String parser r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Word8] -> r
f (ExceptionalT String parser [Word8]
-> ExceptionalT String parser r)
-> ExceptionalT String parser [Word8]
-> ExceptionalT String parser r
forall a b. (a -> b) -> a -> b
$ Int -> ExceptionalT String parser [Word8]
forall (parser :: * -> *).
C parser =>
Int -> Fragile parser [Word8]
getN (Int -> ExceptionalT String parser [Word8])
-> (Int -> Int) -> Int -> ExceptionalT String parser [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> Int
forall a. (Ord a, Num a) => String -> a -> T a
NonNeg.fromNumberMsg String
"Midi.get1" (Int -> ExceptionalT String parser [Word8])
-> ExceptionalT String parser Int
-> ExceptionalT String parser [Word8]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptionalT String parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get1
fetchN :: Int -> ExceptionalT String parser b -> ExceptionalT String parser b
fetchN Int
reqLen ExceptionalT String parser b
act = do
Int
len <- Fragile parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get1
if Int
lenInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
reqLen
then ExceptionalT String parser b
act
else String -> ExceptionalT String parser b
forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp (String -> ExceptionalT String parser b)
-> String -> ExceptionalT String parser b
forall a b. (a -> b) -> a -> b
$
String
"expect " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
reqLen String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" argument(s) for command " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
code String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
", but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len
fetch1 :: (Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> b
f = Int -> ExceptionalT String parser b -> ExceptionalT String parser b
forall (parser :: * -> *) b.
C parser =>
Int -> ExceptionalT String parser b -> ExceptionalT String parser b
fetchN Int
1 ((Word8 -> b)
-> ExceptionalT String parser Word8 -> ExceptionalT String parser b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word8 -> b
f ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte)
fetch2 :: (Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch2 Word8 -> Word8 -> b
f = Int -> ExceptionalT String parser b -> ExceptionalT String parser b
forall (parser :: * -> *) b.
C parser =>
Int -> ExceptionalT String parser b -> ExceptionalT String parser b
fetchN Int
2 ((Word8 -> Word8 -> b)
-> ExceptionalT String parser Word8
-> ExceptionalT String parser Word8
-> ExceptionalT String parser b
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Word8 -> Word8 -> b
f ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte)
fetch3 :: (Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> b
f = Int -> ExceptionalT String parser b -> ExceptionalT String parser b
forall (parser :: * -> *) b.
C parser =>
Int -> ExceptionalT String parser b -> ExceptionalT String parser b
fetchN Int
3 ((Word8 -> Word8 -> Word8 -> b)
-> ExceptionalT String parser Word8
-> ExceptionalT String parser Word8
-> ExceptionalT String parser Word8
-> ExceptionalT String parser b
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Word8 -> Word8 -> Word8 -> b
f ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte ExceptionalT String parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
getByte)
in case Word8
code of
Word8
0x01 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Stop
Word8
0x02 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Play
Word8
0x03 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
DeferredPlay
Word8
0x04 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
FastForward
Word8
0x05 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Rewind
Word8
0x06 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
RecordStrobe
Word8
0x07 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
RecordExit
Word8
0x08 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
RecordPause
Word8
0x09 -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Pause
Word8
0x0A -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Eject
Word8
0x0B -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Chase
Word8
0x0C -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
CommandErrorReset
Word8
0x0D -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Reset
Word8
0x40 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Write
Word8
0x41 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
MaskedWrite
Word8
0x42 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Read
Word8
0x43 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Update
Word8
0x44 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Locate
Word8
0x45 -> (Word8 -> Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> Command
VariablePlay
Word8
0x46 -> (Word8 -> Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> Command
Search
Word8
0x47 -> (Word8 -> Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> Command
Shuttle
Word8
0x48 -> (Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> Command
Step
Word8
0x49 -> (Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> Command
AssignSystemMaster
Word8
0x4A -> (Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> Command
GeneratorCommand
Word8
0x4B -> (Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> Command
MIDITimeCodeCommand
Word8
0x4C -> (Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch2 Word8 -> Word8 -> Command
Move
Word8
0x4D -> (Word8 -> Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> Command
Add
Word8
0x4E -> (Word8 -> Word8 -> Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> Word8 -> Word8 -> b) -> ExceptionalT String parser b
fetch3 Word8 -> Word8 -> Word8 -> Command
Subtract
Word8
0x4F -> (Word8 -> Command) -> Fragile parser Command
forall (parser :: * -> *) b.
C parser =>
(Word8 -> b) -> ExceptionalT String parser b
fetch1 Word8 -> Command
DropFrameAdjust
Word8
0x50 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Procedure
Word8
0x51 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Event
Word8
0x52 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
Group
Word8
0x53 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
CommandSegment
Word8
0x54 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
DeferredVariablePlay
Word8
0x55 -> ([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany [Word8] -> Command
RecordStrobeVariable
Word8
0x7C -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Wait
Word8
0x7F -> Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Resume
Word8
0x00 -> String -> Fragile parser Command
forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp String
"encountered command zero"
Word8
0xF7 -> String -> Fragile parser Command
forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp String
"end of SysEx"
Word8
_ ->
Bool
-> Fragile parser Command
-> Fragile parser Command
-> Fragile parser Command
forall a. Bool -> a -> a -> a
if' (Word8
0x40 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
code Bool -> Bool -> Bool
&& Word8
code Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x78)
(([Word8] -> Command) -> Fragile parser Command
forall (parser :: * -> *) r.
C parser =>
([Word8] -> r) -> ExceptionalT String parser r
fetchMany (([Word8] -> Command) -> Fragile parser Command)
-> ([Word8] -> Command) -> Fragile parser Command
forall a b. (a -> b) -> a -> b
$ Word8 -> [Word8] -> Command
GenericVariableLength Word8
code)
(Command -> Fragile parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return (Command -> Fragile parser Command)
-> Command -> Fragile parser Command
forall a b. (a -> b) -> a -> b
$ Word8 -> Command
GenericNoData Word8
code)
runParser ::
Parser.Partial (SP.T SP.ByteList) a ->
ByteList ->
(SP.PossiblyIncomplete a, [SP.UserMessage])
runParser :: Partial (T ByteList) a
-> [Word8] -> (PossiblyIncomplete a, [String])
runParser Partial (T ByteList) a
p =
State ByteList (PossiblyIncomplete a, [String])
-> ByteList -> (PossiblyIncomplete a, [String])
forall s a. State s a -> s -> a
MS.evalState (WriterT [String] (State ByteList) (PossiblyIncomplete a)
-> State ByteList (PossiblyIncomplete a, [String])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
MW.runWriterT (WriterT [String] (State ByteList) (PossiblyIncomplete a)
-> State ByteList (PossiblyIncomplete a, [String]))
-> WriterT [String] (State ByteList) (PossiblyIncomplete a)
-> State ByteList (PossiblyIncomplete a, [String])
forall a b. (a -> b) -> a -> b
$ Partial (T ByteList) a
-> WriterT [String] (State ByteList) (PossiblyIncomplete a)
forall str a. T str a -> T (State str) a
SP.decons Partial (T ByteList) a
p) (ByteList -> (PossiblyIncomplete a, [String]))
-> ([Word8] -> ByteList)
-> [Word8]
-> (PossiblyIncomplete a, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[Word8] -> ByteList
SP.ByteList