Extremely basic typeahead

basic-typeahead.hs

{-# LANGUAGE TypeFamilies, RecursiveDo, OverloadedStrings #-}

import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Reflex.Dom

main :: IO ()
main = mainWidgetWithHead headWidget bodyWidget

headWidget :: MonadWidget t m => m ()
headWidget = elAttr "link" ("href" =: "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" <> "rel" =: "stylesheet" <> "type" =: "text/css") $ return ()

vals :: [Text]
vals = [ "Ali Abrar"
       , "Ryan Trinkle"
       , "Colin Hobbins"
       , "Cale Gibbard"
       , "Dan Haraj"
       , "Don Salz"
       ]

bodyWidget :: MonadWidget t m => m ()
bodyWidget = do
  let cache = Map.fromList $ zip (map Just vals) vals
  text "Case insensitive search. Look for Ali or Ryan."
  sel <- divClass "dropdown" $ do
    rec i <- textInput $ def
          & attributes .~ (constDyn $ "class" =: "form-control")
          & textInputConfig_setValue .~ fmapMaybe id selectEvent
        let query = value i
            userModifiedQuery = _textInput_input i
            results = ffor query $ \q ->
              Map.filter (\v -> T.isInfixOf (T.toCaseFold q) (T.toCaseFold v)) cache
        hideOnSelect <- holdDyn False $ leftmost
          [ True <$ selectEvent
          , False <$ userModifiedQuery
          ]
        let mkDropdownAttrs results' query' hideOnSelect' = "class" =: "dropdown-menu" <>
              if Map.null results' || T.null query' || hideOnSelect'
                 then "style" =: "display: none;"
                 else "style" =: "display: block;"
            dropdownAttrs = mkDropdownAttrs <$> results <*> query <*> hideOnSelect
        selectEvent <- elDynAttr "ul" dropdownAttrs $
          selectViewListWithKey_ currentlySelected results $ \k v _ -> do
            (li, _) <- el' "li" $ el "a" $ dynText v
            return $ domEvent Click li
        currentlySelected <- holdDyn Nothing $ leftmost
          [ selectEvent
          , Nothing <$ userModifiedQuery
          ]
    return currentlySelected
  divClass "well text-center" $ display sel

-- TODO highlight matching substring in search results
-- TODO allow up/down arrow and enter keys to navigate and select results
-- TODO dismiss dropdown without making a selection

You can see what this looks like when compiled here.