-- 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.Lists as Lists
import qualified Util.Network as Network

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

    Db InstrumentCode
db <- AppDir -> IO (Db InstrumentCode)
LoadInstruments.load forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO AppDir
Path.get_app_dir
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Loaded " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall code. Db code -> Int
Inst.size Db InstrumentCode
db) forall a. [a] -> [a] -> [a]
++ [Char]
" instruments."
    let geometry :: Maybe Geometry
geometry = forall a. [a] -> Maybe a
Lists.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 <- forall a. Fltk a -> IO a
Fltk.run_action 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 (forall code. Db code -> Index
Search.make_index Db InstrumentCode
db)
    Channel
chan <- IO Channel
Fltk.new_channel
    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) forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
result -> do
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"handler thread died: "
            forall a. [a] -> [a] -> [a]
++ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> [Char]
show (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 forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
    [Char] -> IO ()
putStrLn [Char]
"usage: browser [ flags ]"
    [Char] -> IO ()
putStr (forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo [Char]
"" [OptDescr Flag]
options)
    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]
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
""
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT ([Qualified] -> State
State [Qualified]
displayed) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        Fltk.Msg MsgType
typ Text
text <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Qualified -> IO ()
choose_instrument Qualified
qualified
            MsgType
BrowserC.Query -> do
                State
state <- forall s (m :: * -> *). MonadState s m => m s
State.get
                [Qualified]
displayed <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State
state { state_displayed :: [Qualified]
state_displayed = [Qualified]
displayed })
            BrowserC.Unknown CInt
c -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"unknown msg type: " forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ Window MsgType -> Text -> Fltk ()
BrowserC.set_info Window MsgType
win Text
info
    where
    info :: Text
info = forall a. a -> Maybe a -> a
fromMaybe (Text
"not found: " forall a. Semigroup a => a -> a -> a
<> Qualified -> Text
InstT.show_qualified Qualified
qualified) forall a b. (a -> b) -> a -> b
$ do
        let InstT.Qualified Text
synth_name Text
inst_name = Qualified
qualified
        Synth InstrumentCode
synth <- forall code. Text -> Db code -> Maybe (Synth code)
Inst.lookup_synth Text
synth_name (Db -> Db InstrumentCode
db_db Db
db)
        Inst InstrumentCode
inst <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
inst_name (forall code. Synth code -> Map Text (Inst code)
Inst.synth_insts Synth InstrumentCode
synth)
        let synth_doc :: Text
synth_doc = forall code. Synth code -> Text
Inst.synth_doc Synth InstrumentCode
synth forall a. Semigroup a => a -> a -> a
<> Text
" -- "
                forall a. Semigroup a => a -> a -> a
<> Backend -> Text
Inst.backend_name (forall code. Inst code -> Backend
Inst.inst_backend Inst InstrumentCode
inst)
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. a -> Maybe a -> a
fromMaybe [] 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 forall a. Semigroup a => a -> a -> a
<> Text
" -- " forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
Text.null Text
name then Text
"*" else Text
name) forall a. Semigroup a => a -> a -> a
<> Text
" -- "
        forall a. Semigroup a => a -> a -> a
<> Text
synth_doc forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" forall a. Semigroup a => a -> a -> a
<> Text
body
    where
    body :: Text
body = [Tag] -> Text
format_fields forall a b. (a -> b) -> a -> b
$ [Tag] -> Common InstrumentCode -> [Tag]
common_fields [Tag]
tags Common InstrumentCode
common 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 forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then Text
"" else forall a. Pretty a => a -> Text
pretty Environ
env)
    , (Text
"Flags", Text -> [Text] -> Text
Text.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Flag
flags)
    , (Text
"Call map", if forall k a. Map k a -> Bool
Map.null CallMap
call_map then Text
"" else forall a. Pretty a => a -> Text
pretty CallMap
call_map)
    -- code
    , (Text
"Cmds", InstrumentCode -> Text
show_cmds InstrumentCode
code)
    , (Text
"Note generators",
        forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.GeneratorCall forall d. Call d -> DocumentedCall
Derive.extract_doc CallMap (Generator Note)
gen)
    , (Text
"Note transformers",
        forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.TransformerCall forall d. Call d -> DocumentedCall
Derive.extract_doc CallMap (Transformer Note)
trans)
    , (Text
"Track calls",
        forall {call}.
CallType -> (call -> DocumentedCall) -> CallMap call -> Text
show_calls CallType
CallDoc.TrackCall forall d. TrackCall d -> DocumentedCall
Derive.extract_track_doc CallMap (TrackCall Note)
track)
    , (Text
"Val calls", 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 (Generator Note)
gen CallMap (Transformer Note)
trans CallMap (TrackCall Note)
track CallMap ValCall
val = InstrumentCode
-> ScopesT
     (CallMap (Generator Note))
     (CallMap (Transformer 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallType -> [Entry] -> [CallBindings]
CallDoc.entries CallType
ctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap -> [Entry]
CallDoc.call_map_to_entries
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe (Set Flag)
flags)
    , (Text
"Controls", ControlMap -> Text
show_control_map ControlMap
control_map)
    , (Text
"Control defaults", 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", forall a. Pretty a => a -> Text
pretty Maybe PbRange
pb_range)
    , (Text
"Decay", if Maybe RealTime
decay forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing then Text
"" else forall a. Pretty a => a -> Text
pretty Maybe RealTime
decay)
    , (Text
"Scale", forall b a. b -> (a -> b) -> Maybe a -> b
maybe 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 forall a. Eq a => a -> a -> Bool
== Text
orig_name then Text
"" else 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
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$
        forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes AttributeMap
attr_map)
    , (Text
"Controls", [Text] -> Text
Text.unlines
        [ forall a. Pretty a => a -> Text
pretty Control
control forall a. Semigroup a => a -> a -> a
<> Text
"\t" forall a. Semigroup a => a -> a -> a
<> Text
doc
        | (Control
control, Text
doc) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map Control Text
controls
        ])
    , (Text
"Elements", [Text] -> Text
Text.unwords (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
        [ forall a. Pretty a => a -> Text
pretty Control
control forall a. Semigroup a => a -> a -> a
<> Text
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ControlId
id
        | (Control
control, ControlId
id) <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    | Bool
otherwise = Text
"\t" forall a. Semigroup a => a -> a -> a
<> Text
title forall a. Semigroup a => a -> a -> a
<> Text
":\n" forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {a}.
(Pretty a, Pretty a, Pretty a) =>
(a, (a, Maybe a)) -> Text
fmt (forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall {a}. (a, Maybe Keymap) -> Maybe Key
low_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Attributes, ([Keyswitch], Maybe Keymap))]
table)
    where
    attrs :: [[Char]]
attrs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> [Char]
prettys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Attributes, ([Keyswitch], Maybe Keymap))]
table
    longest :: Int
longest = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Maybe a
Lists.maximum (forall a b. (a -> b) -> [a] -> [b]
map 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)) = forall a. a -> Maybe a
Just Key
k
    low_key (a
_, Just (Patch.PitchedKeymap Key
k Key
_ Key
_)) = forall a. a -> Maybe a
Just Key
k
    low_key (a
_, Maybe Keymap
Nothing) = 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 (forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"%-*s\t" Int
longest (forall a. Pretty a => a -> [Char]
prettys a
attrs))
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
keyswitches forall a. Semigroup a => a -> a -> a
<> 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) 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 forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
        [ forall a. Pretty a => a -> Text
pretty MiniVal
val forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Control, Y)
ks
        | (MiniVal
val, (Control, Y)
ks) <- forall k a. Map k a -> [(k, a)]
Map.toList Map MiniVal (Control, Y)
modes
        ] forall a. Semigroup a => a -> a -> a
<> Text
" [default: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Control, Y)
deflt forall a. Semigroup a => a -> a -> a
<> Text
"]"
    | (Text
key, ((Control, Y)
deflt, Map MiniVal (Control, Y)
modes)) <- 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 forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Control
num forall a. Semigroup a => a -> a -> a
<> Text
")"
        | (Control
cont, Control
num) <- 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Handler m -> Text
show_handler (InstrumentCode -> [HandlerId]
Cmd.inst_cmds InstrumentCode
code)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. a -> b -> a
const [Text
"[custom thru]"]) 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 ->
        forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name NamedCmd m
cmd forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> case NoteEntryMap Text
note_entry of
            Cmd.WithoutOctave Map Char Text
m -> [Text] -> Text
list forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Char Text
m
            Cmd.WithOctave Map Int (Map Char Text)
m -> [Text] -> Text
list forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Int (Map Char Text)
m
        where
        list :: [Text] -> Text
list [Text]
xs = Text
"["
            forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a. Ord a => [a] -> [a]
Lists.unique (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]
xs))
            forall a. Semigroup a => a -> a -> a
<> Text
"]"
    Cmd.Handler Maybe (NoteEntryMap Text)
Nothing NamedCmd m
cmd -> forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name NamedCmd m
cmd
    Cmd.Keymap Keymap m
keymap -> forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Doc -> Text
Format.render Text
"\t" Int
10000
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
Format.paragraphs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
v | (Text
k, Text
v) <- forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn 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: " forall a. Semigroup a => a -> a -> a
<> Text
msg
    Patch.InitializeMidi [Message]
msgs -> [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map 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
"\"" forall a. Semigroup a => a -> a -> a
<> Text
s 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 forall a. Semigroup a => a -> a -> a
<> Text
" "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Qualified -> Text
InstT.show_qualified Qualified
qualified)
    Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"send: " forall a. Semigroup a => a -> a -> a
<> Text
cmd
    Text
response <- Text -> IO Text
query Text
cmd
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
response) forall a b. (a -> b) -> a -> b
$
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"response: " forall a. Semigroup a => a -> a -> a
<> Text
response

query :: Text -> IO Text
query :: Text -> IO Text
query = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmdResult -> Text
ReplProtocol.format_result
    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 = forall a b. (a -> b -> Bool) -> [a] -> [b] -> [(Int, Paired a b)]
Lists.diffIndex forall a. Eq a => a -> a -> Bool
(==) [Qualified]
displayed [Qualified]
matches
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Paired Qualified Qualified)]
diff forall a b. (a -> b) -> a -> b
$ \(Int
i, Paired Qualified Qualified
paired) -> case Paired Qualified Qualified
paired of
        Lists.Second Qualified
inst -> Channel -> Fltk () -> IO ()
Fltk.action Channel
chan forall a b. (a -> b) -> a -> b
$
            Window MsgType -> Int -> Text -> Fltk ()
BrowserC.insert_line Window MsgType
win (Int
iforall a. Num a => a -> a -> a
+Int
1) (Qualified -> Text
InstT.show_qualified Qualified
inst)
        Lists.First Qualified
_inst -> Channel -> Fltk () -> IO ()
Fltk.action Channel
chan forall a b. (a -> b) -> a -> b
$
            Window MsgType -> Int -> Fltk ()
BrowserC.remove_line Window MsgType
win (Int
iforall a. Num a => a -> a -> a
+Int
1)
        Paired Qualified Qualified
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return [Qualified]
matches