-- 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

{-# LANGUAGE CPP #-}
-- | Sequencer.
--
-- Dumadak tan wenten alangan.
module App.Main where
#include "hsconfig.h"
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TChan as TChan
import qualified Control.Exception as Exception
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Tuple as Tuple
import qualified Network.Socket as Socket
import qualified System.Environment
import qualified System.IO as IO
#ifdef USE_EKG
import qualified System.Remote.Monitoring
#endif

import qualified Util.Git as Git
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Processes as Processes
import qualified Util.Thread as Thread

import qualified Ui.BlockC as BlockC
import qualified Ui.Fltk as Fltk
import qualified Midi.Encode
import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Midi.MidiDriver as MidiDriver

import qualified Cmd.GlobalKeymap as GlobalKeymap
import qualified Cmd.Repl as Repl
import qualified Cmd.Responder as Responder
import qualified Cmd.SaveGit as SaveGit

import qualified Derive.C.All as C.All
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Symbols as Call.Symbols
import qualified Derive.Instrument.Symbols as Instrument.Symbols
import qualified Derive.Scale.All as Scale.All
import qualified Derive.Scale.Symbols as Scale.Symbols

import qualified Instrument.Inst as Inst
import qualified LogView.Tail as Tail

import qualified App.Config as Config
import qualified App.LoadConfig as LoadConfig
import qualified App.StaticConfig as StaticConfig

import qualified Local.Config

import           Global

-- This is only used by the REPL,  but by importing it here I can make
-- sure it, along with REPL-only modules, are compiled and don't have any
-- errors.
import Cmd.Repl.Environ ()

#ifdef ENABLE_IM
import qualified Util.Audio.PortAudio as PortAudio

initialize_audio :: IO a -> IO a
initialize_audio :: forall a. IO a -> IO a
initialize_audio = forall a. IO a -> IO a
PortAudio.initialize
#else
initialize_audio :: IO a -> IO a
initialize_audio = id
#endif


initialize :: (Interface.Interface -> Socket.Socket -> IO ()) -> IO ()
initialize :: (Interface -> Socket -> IO ()) -> IO ()
initialize Interface -> Socket -> IO ()
app = do
    FilePath
log_fn <- IO FilePath
Tail.log_filename
    Handle
log_hdl <- FilePath -> IO Handle
Log.rotate FilePath
log_fn
    (State -> State) -> IO ()
Log.configure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Log.State
        { state_write_msg :: Msg -> IO ()
state_write_msg = Handle -> Msg -> IO ()
Log.write_json Handle
log_hdl
        , state_priority :: Priority
state_priority = Priority
Log.Debug
        }
    forall a. Initialize a
MidiDriver.initialize FilePath
"karya" ByteString -> Bool
want_message forall a b. (a -> b) -> a -> b
$ \case
        Left Text
err -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"initializing midi: " forall a. Semigroup a => a -> a -> a
<> Text
err
        Right RawInterface WriteMessage
midi_interface -> forall a. IO a -> IO a
initialize_audio forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
Socket.withSocketsDo forall a b. (a -> b) -> a -> b
$ do
            Interface
midi_interface <- RawInterface WriteMessage -> IO Interface
Interface.track_interface RawInterface WriteMessage
midi_interface
            forall a. IO a -> IO a
Git.initialize forall a b. (a -> b) -> a -> b
$ forall a. (Socket -> IO a) -> IO a
Repl.with_socket forall a b. (a -> b) -> a -> b
$ Interface -> Socket -> IO ()
app Interface
midi_interface
    where
    want_message :: ByteString -> Bool
want_message =
        (forall a. Eq a => a -> a -> Bool
/= Message -> ByteString
Midi.Encode.encode (RealtimeMessage -> Message
Midi.RealtimeMessage RealtimeMessage
Midi.ActiveSense))

main :: IO ()
main :: IO ()
main = (Interface -> Socket -> IO ()) -> IO ()
initialize forall a b. (a -> b) -> a -> b
$ \Interface
midi_interface Socket
repl_socket -> do
#ifdef USE_EKG
    System.Remote.Monitoring.forkServer "localhost" 8080
#endif
    -- Handy to filter debugging output.
    Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
IO.stdout BufferMode
IO.LineBuffering
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice Text
Tail.starting_msg
    (StaticConfig
static_config, Text
time) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Text)
Thread.timeActionText
        IO StaticConfig
Local.Config.load_static_config
    let loaded_msg :: Text
loaded_msg = Text
"loaded "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall code. Db code -> Int
Inst.size (StaticConfig -> InstrumentDb
StaticConfig.instrument_db StaticConfig
static_config))
            forall a. Semigroup a => a -> a -> a
<> Text
" instruments, in " forall a. Semigroup a => a -> a -> a
<> Text
time
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice Text
loaded_msg
    Text -> IO ()
Text.IO.putStrLn Text
loaded_msg

    let _x :: t
_x = t
_x -- satellites are out tonight

    let midi :: Midi
midi = StaticConfig -> Midi
StaticConfig.midi StaticConfig
static_config
    let open_read :: Set ReadDevice
open_read = Midi -> Set ReadDevice
StaticConfig.read_devices Midi
midi
    [(ReadDevice, [ReadDevice])]
rdevs <- forall write_message.
RawInterface write_message -> IO [(ReadDevice, [ReadDevice])]
Interface.read_devices Interface
midi_interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
Interface.connect_read_device Interface
midi_interface) (forall a. Set a -> [a]
Set.toList Set ReadDevice
open_read)
    [(WriteDevice, [WriteDevice])]
wdevs <- forall write_message.
RawInterface write_message -> IO [(WriteDevice, [WriteDevice])]
Interface.write_devices Interface
midi_interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall write_message.
RawInterface write_message -> WriteDevice -> IO Bool
Interface.connect_write_device Interface
midi_interface forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(WriteDevice, [WriteDevice])]
wdevs
    Set ReadDevice
-> [(ReadDevice, [ReadDevice])]
-> [(WriteDevice, [WriteDevice])]
-> Map ReadDevice ReadDevice
-> Map WriteDevice WriteDevice
-> IO ()
print_devices Set ReadDevice
open_read [(ReadDevice, [ReadDevice])]
rdevs [(WriteDevice, [WriteDevice])]
wdevs
        (Midi -> Map ReadDevice ReadDevice
StaticConfig.rdev_map Midi
midi) (Midi -> Map WriteDevice WriteDevice
StaticConfig.wdev_map Midi
midi)

    CmdT IO Status
setup_cmd <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StaticConfig -> CmdT IO ()
StaticConfig.post_setup_cmd StaticConfig
static_config) forall a b. (a -> b) -> a -> b
$
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaticConfig -> [FilePath] -> Either Text (CmdT IO Status)
StaticConfig.setup_cmd StaticConfig
static_config
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [FilePath]
System.Environment.getArgs

    -- TODO Sending midi through the whole responder thing is too laggy for
    -- thru.  So give it a shortcut here, but I'll need to give a way to insert
    -- the thru function.  I'll do some responder optimizations first.
    -- thru_chan <- STM.atomically $
    --          STM.dupTChan (Interface.read_channel midi_interface)
    -- Thread.startLogged "midi thru" $
    --     midi_thru remap_rmsg thru_chan write_midi

    TChan Msg
loopback_chan <- forall a. IO (TChan a)
STM.newTChanIO
    TChan UiMsg
msg_chan <- forall a. IO (TChan a)
STM.newTChanIO
    MsgReader
get_msg <- (ReadMessage -> ReadMessage)
-> TChan ReadMessage
-> Socket
-> TChan UiMsg
-> TChan Msg
-> IO MsgReader
Responder.create_msg_reader
        (Map ReadDevice ReadDevice -> ReadMessage -> ReadMessage
remap_read_message (Midi -> Map ReadDevice ReadDevice
StaticConfig.rdev_map Midi
midi))
        (forall write_message.
RawInterface write_message -> TChan ReadMessage
Interface.read_channel Interface
midi_interface) Socket
repl_socket TChan UiMsg
msg_chan
        TChan Msg
loopback_chan

    IO ()
startup_initialization

    Session
session <- IO Session
Repl.make_session
    MVar ()
quit_request <- forall a. a -> IO (MVar a)
MVar.newMVar ()
    MVar [(Fltk (), Text)]
ui_chan <- forall a. a -> IO (MVar a)
MVar.newMVar []
    FilePath -> IO () -> IO ThreadId
Thread.startLogged FilePath
"interpreter" forall a b. (a -> b) -> a -> b
$ do
        Session -> IO ()
Repl.interpreter Session
session
        forall a b. IO a -> IO b -> IO a
`Exception.finally` MVar () -> IO ()
Fltk.quit_ui_thread MVar ()
quit_request
        -- ctrl-C is killing this thread now.  The interaction between signals
        -- and OS threads managed by the GHC RTS is probably unpredictable.
        -- I gather the recommended way is to start a thread for signal
        -- handling, I'll do that if this causes more trouble.

    User
git_user <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error Text
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Int -> IO a
Processes.exit Int
1) forall (m :: * -> *) a. Monad m => a -> m a
return
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Text User)
SaveGit.get_user
    -- Get screens synchronously, so setup_cmd can see them.
    [Rect]
screens <- IO [Rect]
BlockC.get_screens
    FilePath -> IO () -> IO ThreadId
Thread.startLogged FilePath
"responder" forall a b. (a -> b) -> a -> b
$ do
        let loopback :: Msg -> IO ()
loopback Msg
msg = forall a. STM a -> IO a
STM.atomically (forall a. TChan a -> a -> STM ()
TChan.writeTChan TChan Msg
loopback_chan Msg
msg)
        StaticConfig
-> User
-> [Rect]
-> MVar [(Fltk (), Text)]
-> MsgReader
-> Interface
-> CmdT IO Status
-> Session
-> (Msg -> IO ())
-> IO ()
Responder.responder StaticConfig
static_config User
git_user [Rect]
screens MVar [(Fltk (), Text)]
ui_chan MsgReader
get_msg
            Interface
midi_interface CmdT IO Status
setup_cmd Session
session Msg -> IO ()
loopback
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` (\(SomeException
exc :: Exception.SomeException) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"responder thread died from exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc)
            -- It would be possible to restart the responder, but chances are
            -- good it would just die again.
        forall a b. IO a -> IO b -> IO a
`Exception.finally` MVar () -> IO ()
Fltk.quit_ui_thread MVar ()
quit_request
    MVar [(Fltk (), Text)] -> MVar () -> TChan UiMsg -> IO ()
Fltk.event_loop MVar [(Fltk (), Text)]
ui_chan MVar ()
quit_request TChan UiMsg
msg_chan
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(SomeException
exc :: Exception.SomeException) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"ui died from exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc

    forall write_message. RawInterface write_message -> IO ()
Interface.abort Interface
midi_interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Text)
Interface.write_message Interface
midi_interface)
        [RealTime -> Message
Interface.AllNotesOff RealTime
0, RealTime -> Message
Interface.reset_pitch RealTime
0]
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice Text
Tail.quitting_msg

-- | Do one-time startup tasks.
startup_initialization :: IO ()
startup_initialization :: IO ()
startup_initialization = do
    [Symbol] -> IO ()
LoadConfig.symbols forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Symbol]
Call.Symbols.symbols
        , [Symbol]
Scale.Symbols.symbols
        , [Symbol]
Instrument.Symbols.symbols
        ]
    [Style] -> IO ()
LoadConfig.styles [Style]
Config.styles
    -- Report keymap and call overlaps.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn [Text]
GlobalKeymap.all_keymap_errors
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Shadowed]
C.All.shadowed forall a b. (a -> b) -> a -> b
$
        \((Text
name, Module.Module Text
module_), [Symbol]
calls) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"shadowed " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" calls in module "
                forall a. Semigroup a => a -> a -> a
<> Text
module_ forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Symbol]
calls
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ScaleId]
Scale.All.shadowed) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"scales shadowed: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [ScaleId]
Scale.All.shadowed

{-
midi_thru remap_rmsg midi_chan write_midi = forever $ do
    rmsg <- fmap remap_rmsg (STM.atomically (STM.readTChan midi_chan))
    let wmsgs = [Midi.WriteMessage dev 0 msg | (dev, msg) <- process_thru rmsg]
    print rmsg
    mapM_ write_midi wmsgs

process_thru :: Midi.ReadMessage -> [(Midi.WriteDevice, Midi.Message)]
process_thru rmsg = [(Midi.WriteDevice "fm8", Midi.rmsg_msg rmsg)]
-}

remap_read_message :: Map Midi.ReadDevice Midi.ReadDevice
    -> Midi.ReadMessage -> Midi.ReadMessage
remap_read_message :: Map ReadDevice ReadDevice -> ReadMessage -> ReadMessage
remap_read_message Map ReadDevice ReadDevice
dev_map rmsg :: ReadMessage
rmsg@(Midi.ReadMessage { rmsg_dev :: ReadMessage -> ReadDevice
Midi.rmsg_dev = ReadDevice
dev }) =
    ReadMessage
rmsg { rmsg_dev :: ReadDevice
Midi.rmsg_dev = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ReadDevice
dev ReadDevice
dev Map ReadDevice ReadDevice
dev_map }

print_devices :: Set Midi.ReadDevice
    -> [(Midi.ReadDevice, [Midi.ReadDevice])]
    -> [(Midi.WriteDevice, [Midi.WriteDevice])]
    -> Map Midi.ReadDevice Midi.ReadDevice
    -> Map Midi.WriteDevice Midi.WriteDevice
    -> IO ()
print_devices :: Set ReadDevice
-> [(ReadDevice, [ReadDevice])]
-> [(WriteDevice, [WriteDevice])]
-> Map ReadDevice ReadDevice
-> Map WriteDevice WriteDevice
-> IO ()
print_devices Set ReadDevice
opened_rdevs [(ReadDevice, [ReadDevice])]
rdevs [(WriteDevice, [WriteDevice])]
wdevs Map ReadDevice ReadDevice
rdev_map Map WriteDevice WriteDevice
wdev_map = do
    FilePath -> IO ()
putStrLn FilePath
"read devs:"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ReadDevice, [ReadDevice])]
rdevs forall a b. (a -> b) -> a -> b
$ \(ReadDevice
rdev, [ReadDevice]
aliases) -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        [ if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ReadDevice
opened_rdevs) (ReadDevice
rdev forall a. a -> [a] -> [a]
: [ReadDevice]
aliases) then Text
"*" else Text
" "
        , forall a. Pretty a => a -> Text
pretty ReadDevice
rdev
        , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ReadDevice]
aliases then Text
"" else forall a. Pretty a => a -> Text
pretty [ReadDevice]
aliases
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"-> "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ReadDevice
rdev Map ReadDevice ReadDevice
rdev_map
        ]
    FilePath -> IO ()
putStrLn FilePath
"write devs:"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(WriteDevice, [WriteDevice])]
wdevs forall a b. (a -> b) -> a -> b
$ \(WriteDevice
wdev, [WriteDevice]
aliases) -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        [ Text
"*"
        , forall a. Pretty a => a -> Text
pretty WriteDevice
wdev
        , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WriteDevice]
aliases then Text
"" else forall a. Pretty a => a -> Text
pretty [WriteDevice]
aliases
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"<- "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WriteDevice
wdev Map WriteDevice [WriteDevice]
wdev_to_names
        ]
    where wdev_to_names :: Map WriteDevice [WriteDevice]
wdev_to_names = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
Tuple.swap forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map WriteDevice WriteDevice
wdev_map