Advsearch: Add full advanced search query abstraction

I wanted to abstract fields just sufficiently enough to implement
another field for the quick select mode, but ended up writing the full
abstraction for advanced mode.

Upside: This abstraction also works fine for quick select mode, as I had
hoped.

Downside: I haven't yet implemented a "quick select query normalize"
function, which will be needed in order to load the actual field
templates. So no fields are currently displayed and the user can't
search for anything. Very useful.

Code organization is still a bit messy, will work on that.

4 files changed, 238 insertions, 119 deletions

diff --git a/elm/AdvSearch/Fields.elm b/elm/AdvSearch/Fields.elm
new file mode 100644
index 00000000..dfaa125a
--- /dev/null
+++ b/elm/AdvSearch/Fields.elm
@@ -0,0 +1,207 @@
+module AdvSearch.Fields exposing (..)
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Set
+import Lib.DropDown as DD
+import Lib.Api as Api
+import Lib.Html exposing (..)
+import Lib.Util exposing (..)
+import Gen.Types as GT
+import AdvSearch.Query exposing (..)
+
+
+-- TODO: Actual field implementations should be moved into a separate module
+
+langView orig model =
+  let lbl = if orig then "Orig language" else "Language"
+  in
+  ( case Set.size model.sel of
+      0 -> b [ class "grayedout" ] [ text lbl ]
+      1 -> text <| Maybe.withDefault "" <| lookup (Set.toList model.sel |> List.head |> Maybe.withDefault "") GT.languages
+      n -> text <| lbl ++ " (" ++ String.fromInt n ++ ")"
+  , \() ->
+    [ div [ class "advopts" ]
+      [ a [ href "#", onClickD (if orig then SetSingle (not model.single) else SetMode) ]
+        [ text <| "Mode:" ++ if model.single then "single" else if model.and then "and" else "or" ]
+      , linkRadio model.neg SetNeg [ text "invert" ]
+      ]
+    , ul [ style "columns" "2"] <| List.map (\(l,t) -> li [] [ linkRadio (Set.member l model.sel) (SetSel l) [ langIcon l, text t ] ]) GT.languages
+    ]
+  )
+
+langFromQuery = setFromQuery (\q ->
+  case q of
+    QStr "lang" op v -> Just (op, v)
+    _ -> Nothing)
+
+olangFromQuery = setFromQuery (\q ->
+  case q of
+    QStr "olang" op v -> Just (op, v)
+    _ -> Nothing)
+
+
+
+
+-- Generic field abstraction.
+-- (this is where typeclasses would been *awesome*)
+--
+-- The following functions and definitions are only intended to provide field
+-- listings and function dispatchers, if the implementation of anything in here
+-- is longer than a single line, it should get its own definition near where
+-- the rest of that field is defined.
+
+type alias Field = (DD.Config FieldMsg, FieldModel)
+
+type FieldModel
+  = FMCustom Query -- A read-only placeholder for Query values that failed to parse into a Field
+  | FMLang (SetModel String)
+  | FMOLang (SetModel String)
+
+type FieldMsg
+  = FSCustom () -- Not actually used at the moment
+  | FSLang (SetMsg String)
+  | FSOLang (SetMsg String)
+  | FToggle Bool
+
+
+-- XXX: This needs a 'data' argument for global data such as a tag info cache
+fieldUpdate : FieldMsg -> Field -> (Field, Cmd FieldMsg)
+fieldUpdate msg_ (dd, model) =
+  let map1 f m = ((dd, (f m)), Cmd.none)
+  in case (msg_, model) of
+      (FSLang  msg, FMLang  m) -> map1 FMLang  (setUpdate msg m)
+      (FSOLang msg, FMOLang m) -> map1 FMOLang (setUpdate msg m)
+      (FToggle b, _) -> ((DD.toggle dd b, model), Cmd.none)
+      _ -> ((dd, model), Cmd.none)
+
+
+fieldView : Field -> Html FieldMsg
+fieldView (dd, model) =
+  let v f (lbl,cont) = div [ class "elm_dd_input" ] [ DD.view dd Api.Normal (Html.map f lbl) <| \() -> List.map (Html.map f) (cont ()) ]
+  in case model of
+      FMCustom m -> v FSCustom (text "Unrecognized query", \() -> [text ""]) -- TODO: Display the Query
+      FMLang  m -> v FSLang  (langView False m)
+      FMOLang m -> v FSOLang (langView True  m)
+
+
+fieldToQuery : Field -> Maybe Query
+fieldToQuery (_, model) =
+  case model of
+    FMCustom m -> Just m
+    FMLang  m -> setToQuery (QStr "lang" ) m
+    FMOLang m -> setToQuery (QStr "olang") m
+
+
+fieldFromQueryList =
+  let f wrap conv = \q -> Maybe.map wrap (conv q)
+  in [ f FMLang  langFromQuery
+     , f FMOLang olangFromQuery
+     ]
+
+fieldFromQuery : Int -> Query -> Maybe Field
+fieldFromQuery ddid q =
+  let match lst =
+        case lst of
+          [] -> Nothing
+          (x::xs) -> case x q of
+                      Just m -> Just (DD.init ("advsearch_field" ++ String.fromInt ddid) FToggle, m)
+                      Nothing -> match xs
+  in match fieldFromQueryList
+
+
+
+
+-- A Query made up of Fields. This is a higher-level and type-safe alternative
+-- to Query and is what the main UI works with. An FQuery does not always
+-- correspond to a Query as Fields can have empty (= nothing to filter on) or
+-- invalid states. A Query does always have a corresponding FQuery - the Custom
+-- field type is used as fallback in case no other Field types matches.
+
+-- Nodes in the FQuery tree are identified by their path: a list of integers
+-- that index into the list. E.g.:
+--
+--   FAnd              -- path = []
+--   [ FField 1        -- path = [0]
+--   , FOr             -- path = [1]
+--     [ FField 2 ]    -- path = [1,0]
+--   ]
+--
+-- (Alternative strategy is to throw all FQuery nodes into a Dict and have
+-- FAnd/FOr refer to a list of keys instead. Not sure which strategy is more
+-- convenient. Arrays may be more efficient than Lists for some operations)
+
+type FQuery
+  = FAnd (List FQuery)
+  | FOr (List FQuery)
+  | FField Field
+
+
+fqueryToQuery : FQuery -> Maybe Query
+fqueryToQuery fq =
+  let lst wrap l =
+        case List.filterMap fqueryToQuery l of
+          []  -> Nothing
+          [x] -> Just x
+          xs  -> Just (wrap xs)
+  in case fq of
+      FAnd l -> lst QAnd l
+      FOr  l -> lst QOr  l
+      FField f -> fieldToQuery f
+
+
+-- This algorithm is kind of slow. It walks the Query tree and tries every possible Field for each Query found.
+fqueryFromQuery : Int -> Query -> (Int, FQuery)
+fqueryFromQuery ddid q =
+  let lst wrap l = Tuple.mapSecond wrap <| List.foldr (\oq (did,nl) -> let (ndid, fq) = fqueryFromQuery did oq in (ndid, fq::nl)) (ddid,[]) l
+  in case fieldFromQuery ddid q of
+      Just fq -> (ddid+1, FField fq)
+      Nothing ->
+        case q of
+          QAnd l -> lst FAnd l
+          QOr  l -> lst FOr  l
+          _      -> (ddid+1, FField (DD.init ("advsearch_field" ++ String.fromInt ddid) FToggle, FMCustom q))
+
+
+-- Update a node at the given path (unused)
+--fqueryUpdate : List Int -> (FQuery -> FQuery) -> FQuery -> FQuery
+--fqueryUpdate path f q =
+--  case path of
+--    [] -> f q
+--    x::xs ->
+--      case q of
+--        FAnd l -> FAnd (List.indexedMap (\i e -> if i == x then fqueryUpdate xs f e else e) l)
+--        FOr  l -> FOr  (List.indexedMap (\i e -> if i == x then fqueryUpdate xs f e else e) l)
+--        _ -> q
+
+
+-- Replace an existing node at the given path
+fquerySet : List Int -> FQuery -> FQuery -> FQuery
+fquerySet path new q =
+  case path of
+    [] -> new
+    x::xs ->
+      case q of
+        FAnd l -> FAnd (List.indexedMap (\i e -> if i == x then fquerySet xs new e else e) l)
+        FOr  l -> FOr  (List.indexedMap (\i e -> if i == x then fquerySet xs new e else e) l)
+        _ -> q
+
+
+-- Get the node at the given path
+fqueryGet : List Int -> FQuery -> Maybe FQuery
+fqueryGet path q =
+  case path of
+    [] -> Just q
+    x::xs ->
+      case q of
+        FAnd l -> List.drop x l |> List.head |> Maybe.andThen (fqueryGet path)
+        FOr  l -> List.drop x l |> List.head |> Maybe.andThen (fqueryGet path)
+        _ -> Nothing
+
+
+fquerySub : List Int -> (List Int -> FieldMsg -> a) -> FQuery -> Sub a
+fquerySub path wrap q =
+  case q of
+    FAnd l -> Sub.batch <| List.indexedMap (\i -> fquerySub (i::path) wrap) l
+    FOr  l -> Sub.batch <| List.indexedMap (\i -> fquerySub (i::path) wrap) l
+    FField f -> Sub.map (wrap (List.reverse path)) <| DD.sub <| Tuple.first f
diff --git a/elm/AdvSearch/Main.elm b/elm/AdvSearch/Main.elm
index 343cb350..91977ff2 100644
--- a/elm/AdvSearch/Main.elm
+++ b/elm/AdvSearch/Main.elm
@@ -1,86 +1,64 @@
 module AdvSearch.Main exposing (main)
 
--- TODO: This is a quick'n'dirty proof of concept, most of the functionality in
--- here needs to be abstracted so that we can query more than just the
--- language field.
-
 import Html exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (..)
 import Browser
-import Set
 import Json.Encode as JE
 import Json.Decode as JD
-import Lib.DropDown as DD
-import Lib.Api as Api
-import Lib.Html exposing (..)
-import Lib.Util exposing (..)
-import Gen.Types as GT
 import AdvSearch.Query exposing (..)
+import AdvSearch.Fields exposing (..)
+
 
 main : Program JE.Value Model Msg
 main = Browser.element
   { init   = \e -> (init e, Cmd.none)
   , view   = view
   , update = update
-  , subscriptions = \m -> DD.sub m.langDd
+  , subscriptions = \m -> fquerySub [] Field m.query
   }
 
 
 type alias Model =
-  { lang    : SetModel String
-  , langDd  : DD.Config Msg
+  { query : FQuery
   }
 
 
 init : JE.Value -> Model
 init arg =
-  let m = { lang     = setInit
-          , langDd   = DD.init "adv_lang" LangToggle
-          }
-      langFromQuery = setFromQuery (\q -> case q of
-                                           QStr "lang" op v -> Just (op, v)
-                                           _ -> Nothing)
-  in JD.decodeValue decodeQuery arg |> Result.toMaybe |> Maybe.andThen langFromQuery |> Maybe.map (\l -> { m | lang = l }) |> Maybe.withDefault m
-
-
-modelToQuery : Model -> Maybe Query
-modelToQuery m = setToQuery (QStr "lang") m.lang
-
+  -- TODO: Sort and add (empty) fields for quick select mode, it's kind of useless like this
+  { query = JD.decodeValue decodeQuery arg |> Result.toMaybe |> Maybe.map (Tuple.second << fqueryFromQuery 1) |> Maybe.withDefault (FAnd [])
+  }
 
 type Msg
-  = LangToggle Bool
-  | Lang (SetMsg String)
+  = Field (List Int) FieldMsg
+
 
 update : Msg -> Model -> (Model, Cmd Msg)
 update msg model =
   case msg of
-    LangToggle b -> ({ model | langDd = DD.toggle model.langDd b }, Cmd.none)
-    Lang m       -> ({ model | lang = setUpdate m model.lang }, Cmd.none)
+    Field path m ->
+      case fqueryGet path model.query of
+        Just (FField f) -> let (nf, nc) = fieldUpdate m f in ({ model | query = fquerySet path (FField nf) model.query }, Cmd.map (Field path) nc)
+        _ -> (model, Cmd.none)
 
 
 view : Model -> Html Msg
 view model = div [ class "advsearch" ]
-  [ input [ type_ "hidden", id "f", name "f", value <| Maybe.withDefault "" <| Maybe.map (\v -> JE.encode 0 (encodeQuery v)) (modelToQuery model) ] []
-  , div [ class "quickselect" ]
-    [ div [ class "elm_dd_input" ]
-      [ DD.view model.langDd Api.Normal
-        (case Set.size model.lang.sel of
-          0 -> b [ class "grayedout" ] [ text "Language" ]
-          1 -> text <| Maybe.withDefault "" <| lookup (Set.toList model.lang.sel |> List.head |> Maybe.withDefault "") GT.languages
-          n -> text <| "Language (" ++ String.fromInt n ++ ")")
-         <| \() ->
-           [ div [ class "advopts" ]
-             [ a [ href "#", onClickD (Lang SetMode) ] [ text <| "Mode:" ++ if model.lang.single then "single" else if model.lang.and then "and" else "or" ]
-             , linkRadio model.lang.neg (Lang<<SetNeg) [ text "invert" ] -- XXX: Not sure it's obvious what this does, not sure how to improve either
-             ]
-           , ul [ style "columns" "2"] <| List.map (\(l,t) -> li [] [ linkRadio (Set.member l model.lang.sel) (Lang << SetSel l) [ langIcon l, text t ] ]) GT.languages
-           ]
-      ]
+  [ input [ type_ "hidden", id "f", name "f", value <| Maybe.withDefault "" <| Maybe.map (\v -> JE.encode 0 (encodeQuery v)) (fqueryToQuery model.query) ] []
+  , div [ class "quickselect" ] <|
+    (case model.query of
+      FField f -> [Html.map (Field []) (fieldView f)]
+      FOr _    -> []
+      FAnd l   -> List.indexedMap (\i f -> Html.map (Field [i]) (fieldView f)) <| List.filterMap (\q ->
+        case q of
+          FField f -> Just f
+          _ -> Nothing) l
+    ) ++
     --, input [ type_ "button", class "submit", value "Advanced mode" ] [] -- TODO: Advanced mode where you can construct arbitrary queries.
-    , input [ type_ "submit", class "submit", value "Search" ] []
+    [ input [ type_ "submit", class "submit", value "Search" ] []
     ]
   , pre []
-    [ text <| Maybe.withDefault "" <| Maybe.map (\v -> JE.encode 2 (encodeQuery v)) (modelToQuery model)
+    [ text <| Maybe.withDefault "" <| Maybe.map (\v -> JE.encode 2 (encodeQuery v)) (fqueryToQuery model.query)
     ]
   ]
diff --git a/elm/AdvSearch/Query.elm b/elm/AdvSearch/Query.elm
index 8b2ca5fb..c4bbe0bf 100644
--- a/elm/AdvSearch/Query.elm
+++ b/elm/AdvSearch/Query.elm
@@ -82,6 +82,7 @@ type SetMsg a
   = SetSel a Bool
   | SetNeg Bool
   | SetAnd Bool
+  | SetSingle Bool
   | SetMode -- Toggle between single / multi (or) / multi (and)
 
 
@@ -92,10 +93,11 @@ setInit = { sel = Set.empty, single = True, and = False, neg = False, last = Set
 setUpdate : SetMsg comparable -> SetModel comparable -> SetModel comparable
 setUpdate msg model =
   case msg of
-    SetSel v b -> { model | last = Set.empty, sel = if not b then Set.remove v model.sel else if model.single then Set.fromList [v] else Set.insert v model.sel }
-    SetNeg b   -> { model | neg = b }
-    SetAnd b   -> { model | and = b }
-    SetMode    ->
+    SetSel v b  -> { model | last = Set.empty, sel = if not b then Set.remove v model.sel else if model.single then Set.fromList [v] else Set.insert v model.sel }
+    SetNeg b    -> { model | neg = b }
+    SetAnd b    -> { model | and = b }
+    SetSingle b -> { model | single = b }
+    SetMode     ->
       let m = { model | single = not model.single && model.and, and = not model.single && not model.and }
       in  { m | sel = if m.single then Set.fromList <| List.take 1 <| Set.toList m.sel
                       else if model.single && not m.single && not (Set.isEmpty model.last) then m.last
diff --git a/elm/AdvSearch/Set.elm b/elm/AdvSearch/Set.elm
deleted file mode 100644
index 1320036d..00000000
--- a/elm/AdvSearch/Set.elm
+++ /dev/null
@@ -1,68 +0,0 @@
--- Attempt to abstract away a single widget for set-style selections.
-
-module AdvSearch.Set exposing (..)
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import Set
-import Lib.DropDown as DD
-import Lib.Api as Api
-import Lib.Html exposing (..)
-import Lib.Util exposing (..)
-import Gen.Types as GT
-
-
-type alias Model a =
-  { sel    : Set.Set a
-  , dd     : DD.Config (Msg a)
-  , and    : Bool
-  , neg    : Bool
-  }
-
-type Msg a
-  = Toggle Bool
-  | Sel a Bool
-  | And Bool
-  | Neg Bool
-
-
-init : Bool -> String -> Model a
-init id =
-  { sel = Set.empty
-  , dd  = DD.init id Toggle
-  , and = False
-  , neg = False
-  }
-
-update : Msg a -> Model a -> (Model a, Cmd (Msg a))
-update msg model =
-  case msg of
-    Toggle b -> ({ model | dd = DD.toggle model.dd b }, Cmd.none)
-    Sel s b  -> ({ model | sel = if b then Set.insert s model.sel else Set.remove s model.sel }, Cmd.none)
-    And b    -> ({ model | and = b }, Cmd.none)
-    Neg b    -> ({ model | neg = b }, Cmd.none)
-
-
-view : Bool -> String -> List a -> (a -> List (Html (Msg a))) -> Model a -> Html (Msg a)
-view canAnd ddLabel items itemView model = div [ class "elm_dd_input" ]
-  [ DD.view model.dd Api.Normal
-    (case Set.size model.sel of
-      0 -> b [ class "grayedout" ] [ text ddLabel ]
-      1 -> span [] (Set.toList model.sel |> List.head |> Maybe.map itemView |> Maybe.withDefault [])
-      n -> text <| ddLabel ++ " (" ++ String.fromInt n ++ ")")
-     <| \() -> -- TODO: Styling
-       [ if not canAnd then text "" else div []
-         [ linkRadio model.and And [ text "and" ]
-         , text " / "
-         , linkRadio (not model.and) (\b -> And (not b)) [ text "or" ]
-         ]
-       , div []
-         [ linkRadio (not model.neg) (\b -> Neg (not b)) [ text "include" ]
-         , text " / "
-         , linkRadio model.neg Neg [ text "exclude" ]
-         ]
-       --, ul [ style "columns" "2"] <| List.map (\(l,t) -> li [] [ linkRadio (Set.member l model.langSel) (LangSel l) [ langIcon l, text t ] ]) GT.languages
-       , ul [ style "columns" "2"] <| List.map (\l -> li [] [ linkRadio (Set.member l model.sel) (Sel l) (itemView l) ]) items
-       ]
-  ]