module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents'', forwardNoteEvent,
cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch,
unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where
import qualified Sound.ALSA.Exception as AlsaExc
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo
import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Event as Event
-- import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM
import qualified Sound.ALSA.Sequencer.Queue as Queue
-- import qualified Sound.ALSA.Sequencer.RealTime as RealTime
-- import qualified Sound.ALSA.Sequencer.Time as Time
import qualified System.Exit as Exit
import qualified System.IO as IO
import System.Environment (getArgs, )
import Text.Printf
import Control.Monad

import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.List (group, sort)
import Haskore.Basic.Pitch
import Foreign.C.Error (Errno(Errno))
import Control.Exception.Base (try)

unPitch = Event.unPitch
unChannel = Event.unChannel

printChordLn set = printWords $ pitchWords set
printChordLn' = printWords . map (showPitch . Event.unPitch . snd) . Map.keys

joinWords [] = ""
joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls

printWords [] = return () -- print nothing if no words (not an empty line)
printWords ls = putStrLn $ joinWords ls

showChord ls = joinWords $ pitchWords ls

showPitch x =
  let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
  in Haskore.Basic.Pitch.classFormat pitch (show octave)

pitchWords set = map showPitch $ pitchList set
pitchList set = map (Event.unPitch . snd) (Set.toList set)
pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ Set.toList set

prettyNote :: Event.Note -> String
prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
    let pitch = Event.unPitch noteNote
        vlcty = Event.unVelocity noteVelocity
    in
      printf "%d(%d)" pitch vlcty

showPorts ls = joinWords $ map (show . head) $ group $ sort ls

showAlsaPorts h = do
  c <- alsaClients h
  putStrLn ""
  printf "%15s   %s\n" "Ports" "Names"
  printf "%15s   %s\n" "=====" "====="
  forM_ c (\(name, ports) -> printf "%15s   %s\n" (showPorts ports) name)
  putStrLn ""

alsaClients h =
  ClientInfo.queryLoop h $ \cinfo -> do
    ports <- alsaClientPorts h cinfo
    name <- ClientInfo.getName cinfo
    return (name, ports)

alsaClientPorts h cinfo = do
  client <- ClientInfo.getClient cinfo
  PortInfo.queryLoop h client $ \pinfo -> do
    (Client.Cons ports) <- PortInfo.getClient pinfo
    return ports

withAlsaInit k =
  SndSeq.withDefault SndSeq.Nonblock $ \h -> do
    Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell Beats"
    -- In imperative language MIDI sequencer, you rock beat. In Haskell language MIDI sequencer, rock
    -- beat you!
    Port.withSimple h "inout" inout_caps inout_types $ \public ->
      Port.withSimple h "private" private_caps private_types $ \private -> Queue.with h $ \q -> do
        PortInfoM.modify h public $ do
          PortInfoM.setTimestamping True
          PortInfoM.setTimestampReal True
          PortInfoM.setTimestampQueue q

        c <- Client.getId h
        let publicAddr = Addr.Cons c public
            privateAddr = Addr.Cons c private

        Queue.control h q Event.QueueStart Nothing

        k h public private q publicAddr privateAddr
  where
    inout_caps = Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]
    inout_types = Port.types [Port.typeMidiGeneric, Port.typeApplication]
    private_caps = Port.caps [Port.capRead, Port.capWrite]
    private_types = Port.types [Port.typeMidiGeneric]

cmdlineAlsaConnect h public = do
  args <- getArgs
  case args of
    ["0"] ->
      return ()

    ["0", output] ->
      void $ Connect.createTo h public =<< Addr.parse h output

    [input] ->
      void $ Connect.createFrom h public =<< Addr.parse h input

    [input, output] -> do
      void $ Connect.createFrom h public =<< Addr.parse h input
      void $ Connect.createTo h public =<< Addr.parse h output

    _ -> do
      showAlsaPorts h
      IO.hPutStrLn IO.stderr "need arguments: <input-port> [output-port]"
      IO.hPutStrLn IO.stderr "  (use port 0 for no input)"
      Exit.exitFailure

inputPendingLoop h b = do
  mres <- try (Event.inputPending h b)
  case mres of
    (Left e) ->
      case e of
        (AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b
        -- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4)
        -- Happens all the time, means nothing.
        (AlsaExc.Cons location _ code) -> do
          putStrLn $ "alsa_exception: " ++ AlsaExc.show e -- TODO: log this to a file
          AlsaExc.throw location code
    (Right result) -> return result

type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch)
type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity
parseAlsaEvents :: SndSeq.AllowInput mode =>
  SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet
parseAlsaEvents h keysDownInit immediate = loop keysDownInit
  where
    loop keysDown = do
      pending <- inputPendingLoop h True
      if pending == 0 then
        return keysDown
      else do
        ev <- Event.input h
        _ <- immediate ev
        case Event.body ev of
           Event.NoteEv Event.NoteOn n ->
             if Event.unVelocity (Event.noteVelocity n) == 0 then
               loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
             else
               loop (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown)
           Event.NoteEv Event.NoteOff n ->
             loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
           _ -> loop keysDown

parseAlsaEvents'' :: SndSeq.AllowInput mode => SndSeq.T mode -> MidiPitchMap -> (Event.T -> IO t) -> IO ([Event.T], MidiPitchMap)
parseAlsaEvents'' h keysDownInit immediate = loop [] keysDownInit
  where
    loop events keysDown = do
      pending <- inputPendingLoop h True
      if pending == 0 then
        return (events, keysDown)
      else do
        ev <- Event.input h
        _ <- immediate ev
        case Event.body ev of
           Event.NoteEv Event.NoteOn n ->
             if Event.unVelocity (Event.noteVelocity n) == 0 then
               loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown)
             else
               loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown)
           Event.NoteEv Event.NoteOff n ->
             loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown)
           _ -> loop (ev:events) keysDown

type MidiHook = Event.T -> IO ()

forwardNoteEvent :: SndSeq.AllowOutput mode => SndSeq.T mode -> Queue.T -> Addr.T -> MidiHook
forwardNoteEvent h q publicAddr ev = do
--let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }

-- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show

  let (Event.Cons highPriority tag _ time _ _ body) = ev
  void $ Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body)
  void $ Event.drainOutput h