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

{- | A simple tag-oriented query language, and an index for fast-ish searching.

    The syntax is documented by 'Query'.
-}
module Instrument.Search where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Derive.ScoreT as ScoreT
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Instrument.Tag as Tag

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

import           Global


type Search = Query -> [InstT.Qualified]

{- | A simple tag-oriented query language.  Instruments match whose tags match
    all of the given TagKeys exactly, and whose corresponding vals have the
    queried val as a substring.  All the pairs must match, but pairs that match
    nothing won't cause the match to fail.  A tag beginning with @!@ will
    subtract its matches from the result.

    For example, a single word @tag1@ will match all instruments that have the
    given tag.  @tag1=x@ requires that tag1 has an \"x\" in it.

    @tag1=x tag2=y !bad !not=want@ requires both tags to match, the @bad@ tag
    to not be present, and the @not@ tag to not contain \"want\".
    -}
newtype Query = Query [Clause]
    deriving (Int -> Query -> ShowS
[Query] -> ShowS
Query -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Query] -> ShowS
$cshowList :: [Query] -> ShowS
show :: Query -> String
$cshow :: Query -> String
showsPrec :: Int -> Query -> ShowS
$cshowsPrec :: Int -> Query -> ShowS
Show)

-- | Clause inverted? tag val
data Clause = Clause Bool Tag.Key Tag.Value
    deriving (Int -> Clause -> ShowS
[Clause] -> ShowS
Clause -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Clause] -> ShowS
$cshowList :: [Clause] -> ShowS
show :: Clause -> String
$cshow :: Clause -> String
showsPrec :: Int -> Clause -> ShowS
$cshowsPrec :: Int -> Clause -> ShowS
Show)

-- | Search the db.  The input Query is in the parsed db query language, and
-- the output is the names of matching patches, along with their backend.
--
-- An empty query matches everything.
search :: Index -> Search
search :: Index -> Search
search Index
idx (Query []) = forall k a. Map k a -> [k]
Map.keys (Index -> Map Qualified [Tag]
idx_instrument_tags Index
idx)
search Index
idx (Query [Clause]
clauses)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Qualified]
positive = []
    | Bool
otherwise = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Ord a => Set a -> Set a -> Set a
Set.intersection [Set Qualified]
positive forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Qualified
negative
    where
    positive :: [Set Qualified]
positive
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tag]
kvs = [forall k a. Map k a -> Set k
Map.keysSet (Index -> Map Qualified [Tag]
idx_instrument_tags Index
idx)]
        | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
            Index -> [Tag] -> [[Qualified]]
query_matches Index
idx [Tag]
kvs
        where kvs :: [Tag]
kvs = [(Value
k, Value
v) | Clause Bool
False Value
k Value
v <- [Clause]
clauses]
    negative :: Set Qualified
negative = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
        Index -> [Tag] -> [[Qualified]]
query_matches Index
idx [(Value
k, Value
v) | Clause Bool
True Value
k Value
v <- [Clause]
clauses]

tags_of :: Index -> InstT.Qualified -> Maybe [Tag.Tag]
tags_of :: Index -> Qualified -> Maybe [Tag]
tags_of Index
idx Qualified
inst = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Qualified
inst (Index -> Map Qualified [Tag]
idx_instrument_tags Index
idx)

data Index = Index {
    Index -> Map Value (Map Value [Qualified])
idx_by_key :: Map Tag.Key (Map Tag.Value [InstT.Qualified])
    , Index -> Map Qualified [Tag]
idx_instrument_tags :: Map InstT.Qualified [Tag.Tag]
    } deriving (Int -> Index -> ShowS
[Index] -> ShowS
Index -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Index] -> ShowS
$cshowList :: [Index] -> ShowS
show :: Index -> String
$cshow :: Index -> String
showsPrec :: Int -> Index -> ShowS
$cshowsPrec :: Int -> Index -> ShowS
Show)

empty_index :: Index
empty_index :: Index
empty_index = Map Value (Map Value [Qualified]) -> Map Qualified [Tag] -> Index
Index forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

-- | Merge the indices, favoring instruments from the left one.
merge_indices :: Index -> Index -> Index
merge_indices :: Index -> Index -> Index
merge_indices (Index Map Value (Map Value [Qualified])
keys0 Map Qualified [Tag]
inv0) (Index Map Value (Map Value [Qualified])
keys1 Map Qualified [Tag]
inv1) =
    Map Value (Map Value [Qualified]) -> Map Qualified [Tag] -> Index
Index (forall {a}.
Map Value (Map Value [a])
-> Map Value (Map Value [a]) -> Map Value (Map Value [a])
merge_keys Map Value (Map Value [Qualified])
keys0 Map Value (Map Value [Qualified])
keys1) (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Qualified [Tag]
inv0 Map Qualified [Tag]
inv1)
    where
    merge_keys :: Map Value (Map Value [a])
-> Map Value (Map Value [a]) -> Map Value (Map Value [a])
merge_keys = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall {a}. Map Value [a] -> Map Value [a] -> Map Value [a]
merge_vals
    merge_vals :: Map Value [a] -> Map Value [a] -> Map Value [a]
merge_vals = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. [a] -> [a] -> [a]
(++)

make_index :: Inst.Db code -> Index
make_index :: forall code. Db code -> Index
make_index Db code
db = Index
    { idx_by_key :: Map Value (Map Value [Qualified])
idx_by_key = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap (forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap [(Value, (Value, Qualified))]
idx)
    , idx_instrument_tags :: Map Qualified [Tag]
idx_instrument_tags = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Qualified, [Tag])]
inst_tags
    }
    where
    inst_tags :: [(Qualified, [Tag])]
inst_tags = forall code. Db code -> [(Qualified, [Tag])]
instrument_tags Db code
db
    idx :: [(Value, (Value, Qualified))]
idx = [(Value
key, (Value
val, Qualified
inst)) | (Qualified
inst, [Tag]
tags) <- [(Qualified, [Tag])]
inst_tags, (Value
key, Value
val) <- [Tag]
tags]

-- | The query language looks like \"a b= c=d !e=f\", which means
--
-- > Query [Clause False "a" "", Clause False "b" "", Clause False "c" "d",
-- >    Clause True "e" "f"]
--
-- TODO parse quotes for keys or vals with spaces
parse :: Text -> Query
parse :: Value -> Query
parse = [Clause] -> Query
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Value -> Clause
clause forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
Text.words
    where
    clause :: Value -> Clause
clause Value
word
        | Just (Char
'!', Value
pre) <- Value -> Maybe (Char, Value)
Text.uncons Value
pre =
            Bool -> Value -> Value -> Clause
Clause Bool
True Value
pre (Int -> Value -> Value
Text.drop Int
1 Value
post)
        | Bool
otherwise = Bool -> Value -> Value -> Clause
Clause Bool
False Value
pre (Int -> Value -> Value
Text.drop Int
1 Value
post)
        where (Value
pre, Value
post) = (Char -> Bool) -> Value -> Tag
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'=') Value
word

-- * implementation

query_matches :: Index -> [(Tag.Key, Tag.Value)] -> [[InstT.Qualified]]
query_matches :: Index -> [Tag] -> [[Qualified]]
query_matches (Index Map Value (Map Value [Qualified])
idx Map Qualified [Tag]
_) = forall a b. (a -> b) -> [a] -> [b]
map Tag -> [Qualified]
with_tag
    where
    with_tag :: Tag -> [Qualified]
with_tag (Value
key, Value
val) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Value
key Map Value (Map Value [Qualified])
idx of
        Maybe (Map Value [Qualified])
Nothing -> []
        Just Map Value [Qualified]
vals -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((Value
val `Text.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
            (forall k a. Map k a -> [(k, a)]
Map.assocs Map Value [Qualified]
vals)

instrument_tags :: Inst.Db code -> [(InstT.Qualified, [Tag.Tag])]
instrument_tags :: forall code. Db code -> [(Qualified, [Tag])]
instrument_tags = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall code. (Value, Synth code) -> [(Qualified, [Tag])]
synth_tags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Db code -> [(Value, Synth code)]
Inst.synths

synth_tags :: (InstT.SynthName, Inst.Synth code)
    -> [(InstT.Qualified, [Tag.Tag])]
synth_tags :: forall code. (Value, Synth code) -> [(Qualified, [Tag])]
synth_tags (Value
synth_name, Synth code
synth) = do
    (Value
inst_name, Inst code
inst) <- forall k a. Map k a -> [(k, a)]
Map.toList (forall code. Synth code -> Map Value (Inst code)
Inst.synth_insts Synth code
synth)
    let tags :: [Tag]
tags = [Tag] -> [Tag]
normalize_tags forall a b. (a -> b) -> a -> b
$
            forall code. Value -> Value -> Common code -> [Tag]
common_tags Value
synth_name Value
inst_name (forall code. Inst code -> Common code
Inst.inst_common Inst code
inst)
            forall a. [a] -> [a] -> [a]
++ Backend -> [Tag]
inst_tags (forall code. Inst code -> Backend
Inst.inst_backend Inst code
inst)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Value -> Qualified
InstT.Qualified Value
synth_name Value
inst_name, [Tag]
tags)

common_tags :: InstT.SynthName -> InstT.Name -> Common.Common code -> [Tag.Tag]
common_tags :: forall code. Value -> Value -> Common code -> [Tag]
common_tags Value
synth_name Value
inst_name Common code
common =
    (Value
Tag.synth, Value
synth_name)
    forall a. a -> [a] -> [a]
: (Value
Tag.name, Value
inst_name)
    forall a. a -> [a] -> [a]
: forall code. Common code -> [Tag]
Common.common_tags Common code
common

-- | Get tags of an inst, including automatically generated tags.
inst_tags :: Inst.Backend -> [Tag.Tag]
inst_tags :: Backend -> [Tag]
inst_tags = \case
    Inst.Midi Patch
patch -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Value
Tag.backend, Value
"midi")]
        , ControlMap -> [Tag]
control_tags forall a b. (a -> b) -> a -> b
$ Patch -> ControlMap
Patch.patch_control_map Patch
patch
        , case Patch -> InitializePatch
Patch.patch_initialize Patch
patch of
            Patch.InitializeMidi [Message]
msgs
                | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Message -> Bool
Midi.is_sysex [Message]
msgs -> [(Value
Tag.sysex, Value
"")]
                | Bool
otherwise -> []
            InitializePatch
_ -> []
        ]
    Inst.Im {} -> [(Value
Tag.backend, Value
"im")]
    Inst.Sc {} -> [(Value
Tag.backend, Value
"sc")]
    Inst.Dummy {} -> []

normalize_tags :: [Tag.Tag] -> [Tag.Tag]
normalize_tags :: [Tag] -> [Tag]
normalize_tags =
    forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
List.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Value -> Value
Text.toLower Value -> Value
Text.toLower)

control_tags :: Control.ControlMap -> [Tag.Tag]
control_tags :: ControlMap -> [Tag]
control_tags = forall a b. (a -> b) -> [a] -> [b]
map ((,) Value
Tag.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Value
ScoreT.control_name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys