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

{- | The instrument browser is a standalone program to browse the instrument
    database.

    Instruments are in the left pane, and the right pane has information on the
    selected instrument.  A search box above the instrument list accepts
    a simple query language, documneted at 'Search.Query'.

    If you double click on an instrument name, 'choose_instrument' is called on
    the instrument.

    The instrument info is basically just a pretty-printed version of the
    contents of 'Patch.Patch'.

    Some parts of the instrument db may be generated offline, by
    "Instrument.MakeDb".
-}
module Instrument.Browser where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception
import qualified Control.Monad.State as State

import qualified Data.Char as Char
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.Text.Lazy as Lazy

import qualified System.Console.GetOpt as GetOpt
import qualified System.Environment
import qualified System.Exit

import qualified Text.Printf as Printf

import qualified Util.Doc as Doc
import qualified Util.Fltk as Fltk
import qualified Util.FltkUtil as FltkUtil
import qualified Util.Format as Format
import qualified Util.Network as Network
import qualified Util.Seq as Seq

import qualified App.Config as Config
import qualified App.LoadInstruments as LoadInstruments
import qualified App.Path as Path
import qualified App.ReplProtocol as ReplProtocol

import qualified Cmd.CallDoc as CallDoc
import qualified Cmd.Cmd as Cmd
import qualified Derive.Derive as Derive
import qualified Derive.ScoreT as ScoreT
import qualified Instrument.BrowserC as BrowserC
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Instrument.Search as Search
import qualified Instrument.Tag as Tag

import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Sc.Patch as Sc.Patch

import           Global


-- | Send this to the REPL when on a double-click on an instrument.
select_command :: Text
select_command :: Text
select_command = Text
"LInst.set_instrument"

data Flag = Help | Geometry FltkUtil.Geometry
    deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> [Char]
(Int -> Flag -> ShowS)
-> (Flag -> [Char]) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> [Char]
$cshow :: Flag -> [Char]
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"help"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Help) [Char]
"display usage"
    , (Geometry -> Flag) -> OptDescr Flag
forall a. (Geometry -> a) -> OptDescr a
FltkUtil.option Geometry -> Flag
Geometry
    ]

default_geometry :: Maybe FltkUtil.Geometry -> (Int, Int, Int, Int)
default_geometry :: Maybe Geometry -> (Int, Int, Int, Int)
default_geometry = Int -> Int -> Int -> Int -> Maybe Geometry -> (Int, Int, Int, Int)
FltkUtil.xywh Int
50 Int
50 Int
550 Int
600

main :: IO ()
main :: IO ()
main = IO () -> IO ()
forall a. IO a -> IO a
ReplProtocol.initialize (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [[Char]]
args <- IO [[Char]]
System.Environment.getArgs
    ([Flag]
flags, [[Char]]
args) <- case ArgOrder Flag
-> [OptDescr Flag] -> [[Char]] -> ([Flag], [[Char]], [[Char]])
forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
GetOpt.getOpt ArgOrder Flag
forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [[Char]]
args of
        ([Flag]
flags, [[Char]]
args, []) -> ([Flag], [[Char]]) -> IO ([Flag], [[Char]])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [[Char]]
args)
        ([Flag]
_, [[Char]]
_, [[Char]]
errs) -> [Char] -> IO ([Flag], [[Char]])
forall a. [Char] -> IO a
usage ([Char] -> IO ([Flag], [[Char]]))
-> [Char] -> IO ([Flag], [[Char]])
forall a b. (a -> b) -> a -> b
$ [Char]
"flag errors:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. Monoid a => a -> [a] -> a
Seq.join [Char]
", " [[Char]]
errs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. [Char] -> IO a
usage ([Char]
"unparsed args: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) ([Char] -> IO ()
forall a. [Char] -> IO a
usage [Char]
"usage:")

    Db InstrumentCode
db <- AppDir -> IO (Db InstrumentCode)
LoadInstruments.load (AppDir -> IO (Db InstrumentCode))
-> IO AppDir -> IO (Db InstrumentCode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO AppDir
Path.get_app_dir
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Loaded " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Db InstrumentCode -> Int
forall code. Db code -> Int
Inst.size Db InstrumentCode
db) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" instruments."
    let geometry :: Maybe Geometry
geometry = [Geometry] -> Maybe Geometry
forall a. [a] -> Maybe a
Seq.head [Geometry
g | Geometry Geometry
g <- [Flag]
flags]
        (Int
x, Int
y, Int
w, Int
h) = Maybe Geometry -> (Int, Int, Int, Int)
default_geometry Maybe Geometry
geometry
    Window MsgType
win <- Fltk (Window MsgType) -> IO (Window MsgType)
forall a. Fltk a -> IO a
Fltk.run_action (Fltk (Window MsgType) -> IO (Window MsgType))
-> Fltk (Window MsgType) -> IO (Window MsgType)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Fltk (Window MsgType)
BrowserC.create Int
x Int
y Int
w Int
h
    let index_db :: Db
index_db = Db InstrumentCode -> Index -> Db
Db Db InstrumentCode
db (Db InstrumentCode -> Index
forall code. Db code -> Index
Search.make_index Db InstrumentCode
db)
    Channel
chan <- IO Channel
Fltk.new_channel
    IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
Concurrent.forkFinally (Channel -> Window MsgType -> Db -> IO ()
handle_msgs Channel
chan Window MsgType
win Db
index_db) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
result -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"handler thread died: "
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (SomeException -> [Char])
-> (() -> [Char]) -> Either SomeException () -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> () -> [Char]
forall a b. a -> b -> a
const [Char]
"no exception")
                (Either SomeException ()
result :: Either Exception.SomeException ())
        Channel -> IO ()
Fltk.quit Channel
chan
    Channel -> IO ()
Fltk.event_loop Channel
chan

usage :: String -> IO a
usage :: forall a. [Char] -> IO a
usage [Char]
msg = do
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg
    [Char] -> IO ()
putStrLn [Char]
"usage: browser [ flags ]"
    [Char] -> IO ()
putStr ([Char] -> [OptDescr Flag] -> [Char]
forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo [Char]
"" [OptDescr Flag]
options)
    IO a
forall a. IO a
System.Exit.exitFailure

-- | Bundle a Db along with its search index.
data Db = Db {
    Db -> Db InstrumentCode
db_db :: Cmd.InstrumentDb
    , Db -> Index
db_index :: Search.Index
    }

data State = State {
    State -> [Qualified]
state_displayed :: [InstT.Qualified]
    } deriving (Int -> State -> ShowS
[State] -> ShowS
State -> [Char]
(Int -> State -> ShowS)
-> (State -> [Char]) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> [Char]
$cshow :: State -> [Char]
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

handle_msgs :: Fltk.Channel -> BrowserC.Window -> Db -> IO ()
handle_msgs :: Channel -> Window MsgType -> Db -> IO ()
handle_msgs Channel
chan Window MsgType
win Db
db = do
    [Qualified]
displayed <- IO [Qualified] -> IO [Qualified]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Qualified] -> IO [Qualified])
-> IO [Qualified] -> IO [Qualified]
forall a b. (a -> b) -> a -> b
$ Channel
-> Window MsgType -> Db -> [Qualified] -> Text -> IO [Qualified]
process_query Channel
chan Window MsgType
win Db
db [] Text
""
    (StateT State IO () -> State -> IO ())
-> State -> StateT State IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT State IO () -> State -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT ([Qualified] -> State
State [Qualified]
displayed) (StateT State IO () -> IO ()) -> StateT State IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StateT State IO () -> StateT State IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (StateT State IO () -> StateT State IO ())
-> StateT State IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
        Fltk.Msg MsgType
typ Text
text <- IO (Msg MsgType) -> StateT State IO (Msg MsgType)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Msg MsgType) -> StateT State IO (Msg MsgType))
-> IO (Msg MsgType) -> StateT State IO (Msg MsgType)
forall a b. (a -> b) -> a -> b
$ STM (Msg MsgType) -> IO (Msg MsgType)
forall a. STM a -> IO a
STM.atomically (STM (Msg MsgType) -> IO (Msg MsgType))
-> STM (Msg MsgType) -> IO (Msg MsgType)
forall a b. (a -> b) -> a -> b
$ Window MsgType -> STM (Msg MsgType)
forall a. Window a -> STM (Msg a)
Fltk.read_msg Window MsgType
win
        let qualified :: Qualified
qualified = Text -> Qualified
InstT.parse_qualified Text
text
        case MsgType
typ of
            MsgType
BrowserC.Select -> IO () -> StateT State IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT State IO ()) -> IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ Channel -> Window MsgType -> Db -> Qualified -> IO ()
show_info Channel
chan Window MsgType
win Db
db Qualified
qualified
            MsgType
BrowserC.Choose -> IO () -> StateT State IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT State IO ()) -> IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ Qualified -> IO ()
choose_instrument Qualified
qualified
            MsgType
BrowserC.Query -> do
                State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
                [Qualified]
displayed <- IO [Qualified] -> StateT State IO [Qualified]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Qualified] -> StateT State IO [Qualified])
-> IO [Qualified] -> StateT State IO [Qualified]
forall a b. (a -> b) -> a -> b
$
                    Channel
-> Window MsgType -> Db -> [Qualified] -> Text -> IO [Qualified]
process_query Channel
chan Window MsgType
win Db
db (State -> [Qualified]
state_displayed State
state) Text
text
                State -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State
state { state_displayed :: [Qualified]
state_displayed = [Qualified]
displayed })
            BrowserC.Unknown CInt
c -> IO () -> StateT State IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT State IO ()) -> IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown msg type: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
c

-- | Look up the instrument, generate a info sheet on it, and send to the UI.
show_info :: Fltk.Channel -> BrowserC.Window -> Db -> InstT.Qualified
    -> IO ()
show_info :: Channel -> Window MsgType -> Db -> Qualified -> IO ()
show_info Channel
chan Window MsgType
win Db
db Qualified
qualified = Channel -> Fltk () -> IO ()
Fltk.action Channel
chan (Fltk () -> IO ()) -> Fltk () -> IO ()
forall a b. (a -> b) -> a -> b
$ Window MsgType -> Text -> Fltk ()
BrowserC.set_info Window MsgType
win Text
info
    where
    info :: Text
info = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
"not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Qualified -> Text
InstT.show_qualified Qualified
qualified) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
        let InstT.Qualified Text
synth_name Text
inst_name = Qualified
qualified
        Synth InstrumentCode
synth <- Text -> Db InstrumentCode -> Maybe (Synth InstrumentCode)
forall code. Text -> Db code -> Maybe (Synth code)
Inst.lookup_synth Text
synth_name (Db -> Db InstrumentCode
db_db Db
db)
        Inst InstrumentCode
inst <- Text
-> Map Text (Inst InstrumentCode) -> Maybe (Inst InstrumentCode)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
inst_name (Synth InstrumentCode -> Map Text (Inst InstrumentCode)
forall code. Synth code -> Map Text (Inst code)
Inst.synth_insts Synth InstrumentCode
synth)
        let synth_doc :: Text
synth_doc = Synth InstrumentCode -> Text
forall code. Synth code -> Text
Inst.synth_doc Synth InstrumentCode
synth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Backend -> Text
Inst.backend_name (Inst InstrumentCode -> Backend
forall code. Inst code -> Backend
Inst.inst_backend Inst InstrumentCode
inst)
        Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Inst InstrumentCode -> [Tag] -> Text
info_of Text
synth_name Text
inst_name Text
synth_doc Inst InstrumentCode
inst [Tag]
tags
    tags :: [Tag]
tags = [Tag] -> Maybe [Tag] -> [Tag]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Tag] -> [Tag]) -> Maybe [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ Index -> Qualified -> Maybe [Tag]
Search.tags_of (Db -> Index
db_index Db
db) Qualified
qualified

info_of :: InstT.SynthName -> InstT.Name -> Text -> Cmd.Inst
    -> [Tag.Tag] -> Text
info_of :: Text -> Text -> Text -> Inst InstrumentCode -> [Tag] -> Text
info_of Text
synth_name Text
name Text
synth_doc (Inst.Inst Backend
backend Common InstrumentCode
common) [Tag]
tags =
    Text
synth_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
Text.null Text
name then Text
"*" else Text
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
synth_doc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body
    where
    body :: Text
body = [Tag] -> Text
format_fields ([Tag] -> Text) -> [Tag] -> Text
forall a b. (a -> b) -> a -> b
$ [Tag] -> Common InstrumentCode -> [Tag]
common_fields [Tag]
tags Common InstrumentCode
common [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ [Tag]
backend_fields
    backend_fields :: [Tag]
backend_fields = case Backend
backend of
        Inst.Dummy Text
msg -> [(Text
"dummy msg", Text
msg)]
        Inst.Midi Patch
inst -> Text -> Patch -> [Tag]
midi_fields Text
name Patch
inst
        Inst.Im Patch
patch -> Patch -> [Tag]
im_patch_fields Patch
patch
        Inst.Sc Patch
patch -> Patch -> [Tag]
sc_patch_fields Patch
patch

common_fields :: [Tag.Tag] -> Common.Common Cmd.InstrumentCode -> [(Text, Text)]
common_fields :: [Tag] -> Common InstrumentCode -> [Tag]
common_fields [Tag]
tags Common InstrumentCode
common =
    [ (Text
"Environ", if Environ
env Environ -> Environ -> Bool
forall a. Eq a => a -> a -> Bool
== Environ
forall a. Monoid a => a
mempty then Text
"" else Environ -> Text
forall a. Pretty a => a -> Text
pretty Environ
env)
    , (Text
"Flags", Text -> [Text] -> Text
Text.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Flag -> Text) -> [Flag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Flag -> Text
forall a. Show a => a -> Text
showt ([Flag] -> [Text]) -> [Flag] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Flag -> [Flag]
forall a. Set a -> [a]
Set.toList Set Flag
flags)
    , (Text
"Call map", if CallMap -> Bool
forall k a. Map k a -> Bool
Map.null CallMap
call_map then Text
"" else CallMap -> Text
forall a. Pretty a => a -> Text
pretty CallMap
call_map)
    -- code
    , (Text
"Cmds", InstrumentCode -> Text
show_cmds InstrumentCode
code)
    , (Text
"Note generators",
        CallType
-> (Call (GeneratorFunc Note) -> DocumentedCall)
-> CallMap (Call (GeneratorFunc Note))
-> Text
forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.GeneratorCall Call (GeneratorFunc Note) -> DocumentedCall
forall d. Call d -> DocumentedCall
Derive.extract_doc CallMap (Call (GeneratorFunc Note))
gen)
    , (Text
"Note transformers",
        CallType
-> (Call (TransformerF Note) -> DocumentedCall)
-> CallMap (Call (TransformerF Note))
-> Text
forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.TransformerCall Call (TransformerF Note) -> DocumentedCall
forall d. Call d -> DocumentedCall
Derive.extract_doc CallMap (Call (TransformerF Note))
trans)
    , (Text
"Track calls",
        CallType
-> (TrackCall Note -> DocumentedCall)
-> CallMap (TrackCall Note)
-> Text
forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.TrackCall TrackCall Note -> DocumentedCall
forall d. TrackCall d -> DocumentedCall
Derive.extract_track_doc CallMap (TrackCall Note)
track)
    , (Text
"Val calls", CallType -> (ValCall -> DocumentedCall) -> CallMap ValCall -> Text
forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.ValCall ValCall -> DocumentedCall
Derive.extract_val_doc CallMap ValCall
val)
    -- info
    , (Text
"Doc", Text
doc)
    , (Text
"Tags", [Tag] -> Text
show_tags [Tag]
tags)
    -- TODO lost the patch_file field
    ]
    where
    Derive.Scopes CallMap (Call (GeneratorFunc Note))
gen CallMap (Call (TransformerF Note))
trans CallMap (TrackCall Note)
track CallMap ValCall
val = InstrumentCode
-> ScopesT
     (CallMap (Call (GeneratorFunc Note)))
     (CallMap (Call (TransformerF Note)))
     (CallMap (TrackCall Note))
     (CallMap ValCall)
Cmd.inst_calls InstrumentCode
code
    show_calls :: CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
ctype call -> DocumentedCall
extract_doc =
        [CallBindings] -> Text
show_call_bindings ([CallBindings] -> Text)
-> (CallMap call -> [CallBindings]) -> CallMap call -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallType -> [Entry] -> [CallBindings]
CallDoc.entries CallType
ctype ([Entry] -> [CallBindings])
-> (CallMap call -> [Entry]) -> CallMap call -> [CallBindings]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap -> [Entry]
CallDoc.call_map_to_entries
        (CallMap -> [Entry])
-> (CallMap call -> CallMap) -> CallMap call -> [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (call -> DocumentedCall) -> CallMap call -> CallMap
forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
CallDoc.call_map_doc call -> DocumentedCall
extract_doc
    Common.Common
        { common_code :: forall code. Common code -> code
common_code = InstrumentCode
code
        , common_environ :: forall code. Common code -> Environ
common_environ = Environ
env
        , common_doc :: forall code. Common code -> Doc
common_doc = Doc.Doc Text
doc
        , common_flags :: forall code. Common code -> Set Flag
common_flags = Set Flag
flags
        , common_call_map :: forall code. Common code -> CallMap
common_call_map = CallMap
call_map
        } = Common InstrumentCode
common

midi_fields :: InstT.Name -> Patch.Patch -> [(Text, Text)]
midi_fields :: Text -> Patch -> [Tag]
midi_fields Text
name Patch
patch =
    -- important properties
    [ (Text
"Flags", Text -> [Text] -> Text
Text.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Flag -> Text) -> [Flag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Flag -> Text
forall a. Show a => a -> Text
showt ([Flag] -> [Text]) -> [Flag] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Flag -> [Flag]
forall a. Set a -> [a]
Set.toList (Set Flag -> [Flag]) -> Set Flag -> [Flag]
forall a b. (a -> b) -> a -> b
$
        Set Flag -> Maybe (Set Flag) -> Set Flag
forall a. a -> Maybe a -> a
fromMaybe Set Flag
forall a. Monoid a => a
mempty Maybe (Set Flag)
flags)
    , (Text
"Controls", ControlMap -> Text
show_control_map ControlMap
control_map)
    , (Text
"Control defaults", Maybe ControlValMap -> Text
forall a. Pretty a => a -> Text
pretty Maybe ControlValMap
control_defaults)
    -- implementation details
    , (Text
"Attribute map", AttributeMap -> Text
show_attribute_map AttributeMap
attr_map)
    , (Text
"Mode map", ModeMap -> Text
show_mode_map ModeMap
mode_map)
    , (Text
"Pitchbend range", Maybe PbRange -> Text
forall a. Pretty a => a -> Text
pretty Maybe PbRange
pb_range)
    , (Text
"Decay", if Maybe RealTime
decay Maybe RealTime -> Maybe RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RealTime
forall a. Maybe a
Nothing then Text
"" else Maybe RealTime -> Text
forall a. Pretty a => a -> Text
pretty Maybe RealTime
decay)
    , (Text
"Scale", Text -> (Scale -> Text) -> Maybe Scale -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Scale -> Text
forall a. Pretty a => a -> Text
pretty Maybe Scale
scale)
    , (Text
"Initialization", InitializePatch -> Text
show_initialize InitializePatch
initialize)
    , (Text
"Original name", if Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
orig_name then Text
"" else Text -> Text
forall a. Show a => a -> Text
showt Text
orig_name)
    ]
    where
    Patch.Patch
        { patch_name :: Patch -> Text
patch_name = Text
orig_name
        , patch_control_map :: Patch -> ControlMap
patch_control_map = ControlMap
control_map
        , patch_initialize :: Patch -> InitializePatch
patch_initialize = InitializePatch
initialize
        , patch_attribute_map :: Patch -> AttributeMap
patch_attribute_map = AttributeMap
attr_map
        , patch_mode_map :: Patch -> ModeMap
patch_mode_map = ModeMap
mode_map
        , patch_defaults :: Patch -> Settings
patch_defaults = Settings
settings
        } = Patch
patch
    Patch.Settings Maybe (Set Flag)
flags Maybe Scale
scale Maybe RealTime
decay Maybe PbRange
pb_range Maybe ControlValMap
control_defaults = Settings
settings

im_patch_fields :: Im.Patch.Patch -> [(Text, Text)]
im_patch_fields :: Patch -> [Tag]
im_patch_fields (Im.Patch.Patch Map Control Text
controls AttributeMap
attr_map Set Text
elements) =
    [ (Text
"Attributes", Text -> [Text] -> Text
Text.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Attributes -> Text) -> [Attributes] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Text
forall a. Pretty a => a -> Text
pretty ([Attributes] -> [Text]) -> [Attributes] -> [Text]
forall a b. (a -> b) -> a -> b
$
        AttributeMap -> [Attributes]
forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes AttributeMap
attr_map)
    , (Text
"Controls", [Text] -> Text
Text.unlines
        [ Control -> Text
forall a. Pretty a => a -> Text
pretty Control
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
doc
        | (Control
control, Text
doc) <- Map Control Text -> [(Control, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Control Text
controls
        ])
    , (Text
"Elements", [Text] -> Text
Text.unwords (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
elements))
    ]

sc_patch_fields :: Sc.Patch.Patch -> [(Text, Text)]
sc_patch_fields :: Patch -> [Tag]
sc_patch_fields (Sc.Patch.Patch PatchName
_name [Char]
_filename Map Control ControlId
controls) =
    [ (Text
"Controls", [Text] -> Text
Text.unlines
        [ Control -> Text
forall a. Pretty a => a -> Text
pretty Control
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlId -> Text
forall a. Show a => a -> Text
showt ControlId
id
        | (Control
control, ControlId
id) <- Map Control ControlId -> [(Control, ControlId)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Control ControlId
controls
        ])
    ]

format_fields :: [(Text, Text)] -> Text
format_fields :: [Tag] -> Text
format_fields = [Text] -> Text
Text.unlines ([Text] -> Text) -> ([Tag] -> [Text]) -> [Tag] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) ([Text] -> [Text]) -> ([Tag] -> [Text]) -> [Tag] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> Text) -> [Tag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Tag -> Text
field

field :: (Text, Text) -> Text
field :: Tag -> Text
field (Text
title, Text
raw_text)
    | Text -> Bool
Text.null Text
text = Text
""
    | Text -> Int
Text.length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
40 Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
text) =
        Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    | Bool
otherwise = Text
"\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    where text :: Text
text = Text -> Text
Text.strip Text
raw_text

show_attribute_map :: Patch.AttributeMap -> Text
show_attribute_map :: AttributeMap -> Text
show_attribute_map (Common.AttributeMap [(Attributes, ([Keyswitch], Maybe Keymap))]
table) =
    [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Attributes, ([Keyswitch], Maybe Keymap)) -> Text)
-> [(Attributes, ([Keyswitch], Maybe Keymap))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, ([Keyswitch], Maybe Keymap)) -> Text
forall {a} {a} {a}.
(Pretty a, Pretty a, Pretty a) =>
(a, (a, Maybe a)) -> Text
fmt (((Attributes, ([Keyswitch], Maybe Keymap)) -> Maybe Key)
-> [(Attributes, ([Keyswitch], Maybe Keymap))]
-> [(Attributes, ([Keyswitch], Maybe Keymap))]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (([Keyswitch], Maybe Keymap) -> Maybe Key
forall {a}. (a, Maybe Keymap) -> Maybe Key
low_key (([Keyswitch], Maybe Keymap) -> Maybe Key)
-> ((Attributes, ([Keyswitch], Maybe Keymap))
    -> ([Keyswitch], Maybe Keymap))
-> (Attributes, ([Keyswitch], Maybe Keymap))
-> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, ([Keyswitch], Maybe Keymap))
-> ([Keyswitch], Maybe Keymap)
forall a b. (a, b) -> b
snd) [(Attributes, ([Keyswitch], Maybe Keymap))]
table)
    where
    attrs :: [[Char]]
attrs = ((Attributes, ([Keyswitch], Maybe Keymap)) -> [Char])
-> [(Attributes, ([Keyswitch], Maybe Keymap))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> [Char]
forall a. Pretty a => a -> [Char]
prettys (Attributes -> [Char])
-> ((Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes)
-> (Attributes, ([Keyswitch], Maybe Keymap))
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes
forall a b. (a, b) -> a
fst) [(Attributes, ([Keyswitch], Maybe Keymap))]
table
    longest :: Int
longest = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
Seq.maximum (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
attrs)
    -- If this instrument uses a keymap, it's easier to read the attribute map
    -- if I put it in keymap order.
    low_key :: (a, Maybe Keymap) -> Maybe Key
low_key (a
_, Just (Patch.UnpitchedKeymap Key
k)) = Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
    low_key (a
_, Just (Patch.PitchedKeymap Key
k Key
_ Key
_)) = Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
    low_key (a
_, Maybe Keymap
Nothing) = Maybe Key
forall a. Maybe a
Nothing
    fmt :: (a, (a, Maybe a)) -> Text
fmt (a
attrs, (a
keyswitches, Maybe a
maybe_keymap)) =
        -- Still not quite right for lining up columns.
        [Char] -> Text
txt ([Char] -> Int -> ShowS
forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"%-*s\t" Int
longest (a -> [Char]
forall a. Pretty a => a -> [Char]
prettys a
attrs))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Pretty a => a -> Text
pretty a
keyswitches Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (a -> Text) -> Maybe a -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
" "<>) (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Pretty a => a -> Text
pretty) Maybe a
maybe_keymap

show_mode_map :: Patch.ModeMap -> Text
show_mode_map :: ModeMap -> Text
show_mode_map (Patch.ModeMap Map Text ((Control, Y), Map MiniVal (Control, Y))
table) = [Text] -> Text
Text.unlines
    [ Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
        [ MiniVal -> Text
forall a. Pretty a => a -> Text
pretty MiniVal
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Control, Y) -> Text
forall a. Pretty a => a -> Text
pretty (Control, Y)
ks
        | (MiniVal
val, (Control, Y)
ks) <- Map MiniVal (Control, Y) -> [(MiniVal, (Control, Y))]
forall k a. Map k a -> [(k, a)]
Map.toList Map MiniVal (Control, Y)
modes
        ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [default: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Control, Y) -> Text
forall a. Pretty a => a -> Text
pretty (Control, Y)
deflt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    | (Text
key, ((Control, Y)
deflt, Map MiniVal (Control, Y)
modes)) <- Map Text ((Control, Y), Map MiniVal (Control, Y))
-> [(Text, ((Control, Y), Map MiniVal (Control, Y)))]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text ((Control, Y), Map MiniVal (Control, Y))
table
    ]

show_control_map :: Control.ControlMap -> Text
show_control_map :: ControlMap -> Text
show_control_map ControlMap
cmap =
    Text -> [Text] -> Text
Text.intercalate Text
", " [Control -> Text
ScoreT.control_name Control
cont Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Control -> Text
forall a. Show a => a -> Text
showt Control
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        | (Control
cont, Control
num) <- ControlMap -> [(Control, Control)]
forall k a. Map k a -> [(k, a)]
Map.toList ControlMap
cmap]

show_cmds :: Cmd.InstrumentCode -> Text
show_cmds :: InstrumentCode -> Text
show_cmds InstrumentCode
code = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (Handler CmdId -> Text) -> [Handler CmdId] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Handler CmdId -> Text
forall (m :: * -> *). Handler m -> Text
show_handler (InstrumentCode -> [Handler CmdId]
Cmd.inst_cmds InstrumentCode
code)
    , [Text] -> (ThruFunction -> [Text]) -> Maybe ThruFunction -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Text] -> ThruFunction -> [Text]
forall a b. a -> b -> a
const [Text
"[custom thru]"]) (Maybe ThruFunction -> [Text]) -> Maybe ThruFunction -> [Text]
forall a b. (a -> b) -> a -> b
$ InstrumentCode -> Maybe ThruFunction
Cmd.inst_thru InstrumentCode
code
    ]

show_handler :: Cmd.Handler m -> Text
show_handler :: forall (m :: * -> *). Handler m -> Text
show_handler = \case
    Cmd.Handler (Just NoteEntryMap Text
note_entry) NamedCmd m
cmd ->
        NamedCmd m -> Text
forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name NamedCmd m
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case NoteEntryMap Text
note_entry of
            Cmd.WithoutOctave Map Char Text
m -> [Text] -> Text
list ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Map Char Text -> [Text]
forall k a. Map k a -> [a]
Map.elems Map Char Text
m
            Cmd.WithOctave Map Int (Map Char Text)
m -> [Text] -> Text
list ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Map Char Text -> [Text]) -> [Map Char Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Map Char Text -> [Text]
forall k a. Map k a -> [a]
Map.elems ([Map Char Text] -> [Text]) -> [Map Char Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Int (Map Char Text) -> [Map Char Text]
forall k a. Map k a -> [a]
Map.elems Map Int (Map Char Text)
m
        where
        list :: [Text] -> Text
list [Text]
xs = Text
"["
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
xs))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    Cmd.Handler Maybe (NoteEntryMap Text)
Nothing NamedCmd m
cmd -> NamedCmd m -> Text
forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name NamedCmd m
cmd
    Cmd.Keymap Keymap m
keymap -> [Text] -> Text
forall a. Pretty a => a -> Text
pretty ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (NamedCmd m -> Text) -> [NamedCmd m] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map NamedCmd m -> Text
forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name ([NamedCmd m] -> [Text]) -> [NamedCmd m] -> [Text]
forall a b. (a -> b) -> a -> b
$ Keymap m -> [NamedCmd m]
forall k a. Map k a -> [a]
Map.elems Keymap m
keymap

show_call_bindings :: [CallDoc.CallBindings] -> Text
show_call_bindings :: [CallBindings] -> Text
show_call_bindings = Text -> Text
Lazy.toStrict (Text -> Text)
-> ([CallBindings] -> Text) -> [CallBindings] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Doc -> Text
Format.render Text
"\t" Int
10000
    (Doc -> Text) -> ([CallBindings] -> Doc) -> [CallBindings] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
Format.paragraphs ([Doc] -> Doc)
-> ([CallBindings] -> [Doc]) -> [CallBindings] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CallBindings -> Doc) -> [CallBindings] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> CallBindings -> Doc
CallDoc.call_bindings_text Bool
False)
    -- Let fltk do the wrapping.  Of course it doesn't know how the indentation
    -- works, so wrapped lines don't get indented, but it doesn't look that
    -- bad.

show_tags :: [(Text, Text)] -> Text
show_tags :: [Tag] -> Text
show_tags [Tag]
tags =
    [Text] -> Text
Text.unwords [Text -> Text
quote Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
v | (Text
k, Text
v) <- (Tag -> Text) -> [Tag] -> [Tag]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on Tag -> Text
forall a b. (a, b) -> a
fst [Tag]
tags]

show_initialize :: Patch.InitializePatch -> Text
show_initialize :: InitializePatch -> Text
show_initialize = \case
    InitializePatch
Patch.NoInitialization -> Text
""
    Patch.InitializeMessage Text
msg -> Text
"Message: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
    Patch.InitializeMidi [Message]
msgs -> [Text] -> Text
Text.unlines ((Message -> Text) -> [Message] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Message -> Text
forall a. Pretty a => a -> Text
pretty [Message]
msgs)

quote :: Text -> Text
quote :: Text -> Text
quote Text
s
    | (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
Char.isSpace Text
s = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
    | Bool
otherwise = Text
s

-- | Send the chosen instrument to the sequencer.  This will send
-- @change_instrument \"synth/inst\"@ to the REPL port.
choose_instrument :: InstT.Qualified -> IO ()
choose_instrument :: Qualified -> IO ()
choose_instrument Qualified
qualified = do
    let cmd :: Text
cmd = Text
select_command Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt (Qualified -> Text
InstT.show_qualified Qualified
qualified)
    Text -> IO ()
Text.IO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"send: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd
    Text
response <- Text -> IO Text
query Text
cmd
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
response) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> IO ()
Text.IO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
response

query :: Text -> IO Text
query :: Text -> IO Text
query = (CmdResult -> Text) -> IO CmdResult -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmdResult -> Text
ReplProtocol.format_result
    (IO CmdResult -> IO Text)
-> (Text -> IO CmdResult) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Text -> IO CmdResult
ReplProtocol.query_cmd ([Char] -> Addr
Network.Unix [Char]
Config.repl_socket_name)

-- | Find instruments that match the query, and update the UI incrementally.
process_query :: Fltk.Channel -> BrowserC.Window -> Db -> [InstT.Qualified]
    -> Text -> IO [InstT.Qualified]
process_query :: Channel
-> Window MsgType -> Db -> [Qualified] -> Text -> IO [Qualified]
process_query Channel
chan Window MsgType
win Db
db [Qualified]
displayed Text
query = do
    let matches :: [Qualified]
matches = Index -> Search
Search.search (Db -> Index
db_index Db
db) (Text -> Query
Search.parse Text
query)
        diff :: [(Int, Paired Qualified Qualified)]
diff = (Qualified -> Qualified -> Bool)
-> [Qualified]
-> [Qualified]
-> [(Int, Paired Qualified Qualified)]
forall a b. (a -> b -> Bool) -> [a] -> [b] -> [(Int, Paired a b)]
Seq.diff_index Qualified -> Qualified -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Qualified]
displayed [Qualified]
matches
    [(Int, Paired Qualified Qualified)]
-> ((Int, Paired Qualified Qualified) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Paired Qualified Qualified)]
diff (((Int, Paired Qualified Qualified) -> IO ()) -> IO ())
-> ((Int, Paired Qualified Qualified) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Paired Qualified Qualified
paired) -> case Paired Qualified Qualified
paired of
        Seq.Second Qualified
inst -> Channel -> Fltk () -> IO ()
Fltk.action Channel
chan (Fltk () -> IO ()) -> Fltk () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Window MsgType -> Int -> Text -> Fltk ()
BrowserC.insert_line Window MsgType
win (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Qualified -> Text
InstT.show_qualified Qualified
inst)
        Seq.First Qualified
_inst -> Channel -> Fltk () -> IO ()
Fltk.action Channel
chan (Fltk () -> IO ()) -> Fltk () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Window MsgType -> Int -> Fltk ()
BrowserC.remove_line Window MsgType
win (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        Paired Qualified Qualified
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [Qualified] -> IO [Qualified]
forall (m :: * -> *) a. Monad m => a -> m a
return [Qualified]
matches