{-# LANGUAGE NondecreasingIndentation #-}
module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord) 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 (when, forM_, forM)

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

printChordLn set = printWords $ pitchWords set

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 . Event.unPitch) $ 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 = do
  portsNames <- ClientInfo.queryLoop h $ \cinfo -> do
    ports <- alsaClientPorts h cinfo
    name <- ClientInfo.getName cinfo
    return (name, ports)
  return portsNames

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

withAlsaInit k = do
  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"
     (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
     (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
  Port.withSimple h "private"
     (Port.caps [Port.capRead, Port.capWrite])
     (Port.types [Port.typeMidiGeneric]) $ \private -> do
  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

cmdlineAlsaConnect h public = do
  args <- getArgs
  case args of

     [input, output] -> do
        (Connect.createFrom h public =<< Addr.parse h input)
        (Connect.createTo   h public =<< Addr.parse h output)
        return ()

     _ -> do
        showAlsaPorts h
        IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
        Exit.exitFailure

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

parseAlsaEvents h keysDown immediate = loop keysDown
  where
    loop keysDown = do
      pending <- inputPendingLoop h True
      if (pending == 0) then
        return keysDown
      else do
        ev <- Event.input h
        case Event.body ev of
           Event.NoteEv Event.NoteOn n  -> do
             immediate ev
             loop (Set.insert (Event.noteNote n) keysDown)
           Event.NoteEv Event.NoteOff n -> do
             immediate ev
             loop (Set.delete (Event.noteNote n) keysDown)
           _ -> loop keysDown

forwardNoteEvent h q publicAddr ev = do
  let mkEv e = (Event.simple publicAddr e) { Event.queue = q, Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0 }
  let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
  case Event.body ev of
     Event.NoteEv Event.NoteOn  n -> immediate Event.NoteEv Event.NoteOn n
     Event.NoteEv Event.NoteOff n -> immediate Event.NoteEv Event.NoteOff n
     -- TODO: forward other event types?
     _ -> return ()