suggestion.purs

module Throttle where

import Prelude (Unit(), unit, pure, ($), (<$>), (<#>), bind, void, (++), (==))
import Global (encodeURIComponent)
import Data.Maybe (Maybe(..))
import Data.Array ((!!))
import Data.Traversable (for)
import Data.Functor ((<$))
import Data.Date (Now(), nowEpochMilliseconds)
import Data.Time (Milliseconds(Milliseconds))
import Control.Monad (when)
import Control.Monad.Aff (Aff(), runAff, makeAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Error(), throwException)
import Halogen (HalogenEffects(), ComponentDSL(), Natural(), ComponentHTML(), Component(), runUI, component, get, modify, liftEff', liftAff')
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (className)
import Halogen.HTML.Indexed (text, div, span, a, input)
import Halogen.HTML.Events.Indexed (onValueInput)
import Halogen.HTML.Properties.Indexed (href, class_, placeholder)
import Data.Argonaut.Core (Json(), toArray, toString)
import DOM (DOM())
import DOM.Timer (Timer(), timeout)


foreign import _jsonp :: forall eff . String -> String -> (Error -> Eff (dom :: DOM | eff) Unit) -> (Json -> Eff (dom :: DOM | eff) Unit) -> Eff (dom :: DOM | eff) Unit

jsonp :: forall eff . String -> String -> Aff (dom :: DOM | eff) Json
jsonp callback url = makeAff (_jsonp callback url)

parse :: Json -> Maybe (Array String)
parse json = do
    xs <- toArray json
    ys <- xs !! 1 
    entries <- toArray ys
    for entries \r -> do
        m <- toArray r
        s <- m !! 0
        toString s


throttle :: forall a f eff 
          . Int
         -> ComponentDSL { inputTime :: Milliseconds | a } f (Aff (HalogenEffects (timer :: Timer, now :: Now | eff))) Unit 
         -> ComponentDSL { inputTime :: Milliseconds | a } f (Aff (HalogenEffects (timer :: Timer, now :: Now | eff))) Unit
throttle span action = do
    inputTime <- liftEff' nowEpochMilliseconds
    modify _ { inputTime = inputTime }
    liftAff' $ sleep span
    inputTime' <- get <#> _.inputTime
    when (inputTime' == inputTime) action

sleep :: forall eff . Int -> Aff (timer :: Timer | eff) Unit
sleep milliseconds = makeAff \reject resolve -> void $ timeout milliseconds (resolve unit)

data FetchState = Initialized | OnInput | Fetching String | Complete (Maybe (Array String))

type State = { inputTime :: Milliseconds, fetch :: FetchState }

data Query a = Input String a

type Effects = HalogenEffects (timer :: Timer, now:: Now)

ui :: Component State Query (Aff Effects)
ui = component render eval

  where

    render :: State -> ComponentHTML Query
    render s = div [class_ (className "outer")] [
        div [class_ (className "title")] [
            span [class_ (className "glyphicon glyphicon-search")] [],
            text "Google Suggest Tool"
        ],
        div [] [input [onValueInput (Halogen.HTML.Events.Indexed.input Input), placeholder "input some queries..."]],
        div [] case s.fetch of
            Initialized -> [text "(Initialized)"]
            OnInput -> [text "(On Input ...)"]
            Fetching token -> [text token]
            Complete (Just xs) -> (\s -> div [] [a [href ("https://www.google.co.jp/search?q=" ++ s)] [text s]]) <$> xs
            Complete Nothing -> [text "(Error)"]
    ]

    eval :: Natural Query (ComponentDSL State Query (Aff Effects))
    eval (Input str next) = next <$ do
        modify _ { fetch = OnInput }
        throttle 1000 do                             -- 1秒間入力がなくなるまで以降の処理を待機する
            modify _ { fetch = Fetching str }
            res <- liftAff' $ jsonp "suggestCallBack" ("http://www.google.com/complete/search?hl=en&jsonp=suggestCallBack&client=youtube&q=" ++ encodeURIComponent str) 
            modify _ { fetch = Complete (parse res) }

main :: Eff Effects Unit
main = runAff throwException pure $ void do
    app <- runUI ui { inputTime: Milliseconds 0.0, fetch: Initialized }
    onLoad $ appendToBody app.node