Add test for premature effect performing

module Test.Main where

import Prelude
import Control.Apply
import Control.Bind

import Control.Monad.Eff.Console
import Control.Monad.Eff.Console.Unsafe

import Data.Posix.Signal (Signal(..))
import Node.Encoding (Encoding(UTF8))
import Node.Buffer as Buffer
import Node.ChildProcess
import Node.Stream (onData)

main = do
  log "spawns processes ok"
  spawnLs

  log "emits an error if executable does not exist"
  nonExistentExecutable $ do
    log "all good."

  log "doesn't perform effects too early"
  ls <- spawn "ls" ["-la"] defaultSpawnOptions
  let unused = kill SIGTERM ls
  onExit ls \exit ->
    case exit of
      Normally 0 ->
        log "All good!"
      _ -> do
        log ("Bad exit: expected `Normally 0`, got: " <> show exit)

  log "kills processes"
  ls <- spawn "ls" ["-la"] defaultSpawnOptions
  kill SIGTERM ls
  onExit ls \exit ->
    case exit of
      BySignal SIGTERM ->
        log "All good!"
      _ -> do
        log ("Bad exit: expected `BySignal SIGTERM`, got: " <> show exit)

spawnLs = do
  ls <- spawn "ls" ["-la"] defaultSpawnOptions
  onExit ls \exit ->
      log $ "ls exited: " <> show exit
  onData (stdout ls) (Buffer.toString UTF8 >=> log)

nonExistentExecutable done = do
  ch <- spawn "this-does-not-exist" [] defaultSpawnOptions
  onError ch (\err -> logAny err *> done)

module Test.Main where

import Prelude
import Control.Apply
import Control.Bind

import Control.Monad.Eff.Console
import Control.Monad.Eff.Console.Unsafe

import Data.Posix.Signal (Signal(..))
import Node.Encoding (Encoding(UTF8))
import Node.Buffer as Buffer
import Node.ChildProcess
import Node.Stream (onData)

main = do
  log "spawns processes ok"
  spawnLs

  log "emits an error if executable does not exist"
  nonExistentExecutable $ do
    log "all good."

spawnLs = do
  ls <- spawn "ls" ["-la"] defaultSpawnOptions
  onExit ls \exit ->
      log $ "ls exited: " <> show exit
  onData (stdout ls) (Buffer.toString UTF8 >=> log)

nonExistentExecutable done = do
  ch <- spawn "this-does-not-exist" [] defaultSpawnOptions
  onError ch (\err -> logAny err *> done)


More backend-agnostic IR

More backend-agnostic IR

Original commit aad6db9294a0fb281ab73652c700d367e32535e0

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap, concatMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data IRClassData = IRClassData { name :: String, properties :: StrMap.StrMap IRType }
data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const $ IRNull)
    (\b -> IRBool)
    (\x -> IRDouble)
    (\s -> IRString)
    (case _ of
        [] -> IRArray IRNothing
        a ->
            let elementType = makeTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            IRArray elementType)
    (\o ->
        let props = mapProperties o in
        IRClass (IRClassData { name: name, properties: props }))
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap IRType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: IRType -> Array IRClassData
gatherClassesFromType (IRClass classData) =
    let IRClassData { name, properties } = classData in
    classData : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = (renderTypeToCSharp a) <> "[]"
renderTypeToCSharp (IRClass (IRClassData { name, properties })) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> String
renderClassToCSharp (IRClassData { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name irType = "    public " <> (renderTypeToCSharp irType) <> " " <> name <> " { get; set; }"

renderClassesToCSharp :: Array IRClassData -> String
renderClassesToCSharp classes =
    foldMap (\c -> (renderClassToCSharp c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap, concatMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data CSharpClass = CSClass { name :: String, properties :: StrMap.StrMap CSharpType }
data CSharpType
    = CSClassType CSharpClass
    | CSArray CSharpType
    | CSObject
    | CSBool
    | CSDouble
    | CSString

makeCSharpTypeFromJson :: String -> Json -> CSharpType
makeCSharpTypeFromJson name json = foldJson
    (const $ CSObject)
    (\b -> CSBool)
    (\x -> CSDouble)
    (\s -> CSString)
    (case _ of
        [] -> CSArray CSObject
        a ->
            let elementType = makeCSharpTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            CSArray elementType)
    (\o ->
        let props = mapProperties o in
        CSClassType (CSClass { name: name, properties: props }))
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap CSharpType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeCSharpTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: CSharpType -> Array CSharpClass
gatherClassesFromType (CSClassType c) =
    let CSClass { name, properties } = c in
    c : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (CSArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderCSharpType :: CSharpType -> String
renderCSharpType (CSArray a) = (renderCSharpType a) <> "[]"
renderCSharpType (CSClassType (CSClass { name, properties })) = name
renderCSharpType CSObject = "object"
renderCSharpType CSBool = "bool"
renderCSharpType CSDouble = "double"
renderCSharpType CSString = "string"

renderCSharpClass :: CSharpClass -> String
renderCSharpClass (CSClass { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name csType = "    public " <> (renderCSharpType csType) <> " " <> name <> " { get; set; }"

renderCSharpClasses :: Array CSharpClass -> String
renderCSharpClasses classes =
    foldMap (\c -> (renderCSharpClass c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeCSharpTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderCSharpClasses


Refresh cards.

Refresh cards.

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, getValue, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, snoc, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F, readString)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"
  citiesSelect <- select "#selectCityToAdd"
  body <- body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body
  on' "click" "#butAddCancel" (\_ _ -> toggleAddDialog false addDialog) body
  on' "click" "#butAddCity" (\_ _ -> addSelectedCity stateRef citiesSelect addDialog) body
  on' "click" "#butRefresh" (\_ _ -> updateForecasts stateRef) body

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else do
      setText cardData.created cardLastUpdatedElem
      find "> .location" card >>= setText cardData.label
      find "> .description" card >>= setText current.text
      find "> .date" card >>= setText current.date
      find ".current .icon" card >>= setClass (getIconClass current.code) true
      find ".current .temperature .value" card >>= (setText $ show current.temp)
      find ".current .sunrise" card >>= setText astronomy.sunrise
      find ".current .sunset" card >>= setText astronomy.sunset
      find ".current .humidity" card >>= (setText $ show humidity <> "%")
      find ".current .wind .value" card >>= (setText $ show wind.speed)
      find ".current .wind .direction" card >>= (setText $ show wind.direction)

      nextDays <- find ".future .oneday" card >>= toArray
      ndw <- nextDaysOfWeek
      foreachE (zip3 nextDays forcast ndw) updateNextDay

      AppState state <- readRef stateRef
      when state.isLoading do
        hide state.spinner
        modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

      where
        channel = cardData.channel
        astronomy = channel.astronomy
        current = channel.item.condition
        forcast = channel.item.forecast
        humidity = channel.atmosphere.humidity
        wind = channel.wind

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t = do
  find ".icon" c >>= setClass (getIconClass daily.code) true
  find ".date" c >>= setText wd
  find ".temp-high .value" c >>= (setText $ show daily.high)
  find ".temp-low .value" c >>= (setText $ show daily.low)
  where
    c = get1 t
    daily = get2 t
    wd = get3 t

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

addSelectedCity :: forall e
   . Ref AppState
  -> JQuery
  -> JQuery
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         , storage :: STORAGE
         | e) Unit
addSelectedCity stateRef citiesSelect addDialog = do
  selectedOpt <- find "option:selected" citiesSelect
  label <- getText selectedOpt
  value <- getValue selectedOpt
  case runExcept $ readString value of
    Left err -> log $ show err
    Right key -> do
      getForecast stateRef key label
      modifyRef stateRef $ storeSelectedCity $ SelectedCity { key, label }
      saveSelectedCities stateRef
      toggleAddDialog false addDialog

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Iterate all of the cards and attempt to get the latest forecast data.
updateForecasts
  :: forall e
   . Ref AppState
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , dom :: DOM
         , err :: EXCEPTION
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e
         ) Unit
updateForecasts stateRef = do
  AppState state <- readRef stateRef
  foreachE state.selectedCities \(SelectedCity { key, label }) -> getForecast stateRef key label

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

storeSelectedCity :: SelectedCity -> AppState -> AppState
storeSelectedCity city (AppState state) =
  AppState state { selectedCities = snoc state.selectedCities city }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, getValue, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, snoc, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F, readString)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"
  citiesSelect <- select "#selectCityToAdd"
  body <- body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body
  on' "click" "#butAddCancel" (\_ _ -> toggleAddDialog false addDialog) body
  on' "click" "#butAddCity" (\_ _ -> addSelectedCity stateRef citiesSelect addDialog) body

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else do
      setText cardData.created cardLastUpdatedElem
      find "> .location" card >>= setText cardData.label
      find "> .description" card >>= setText current.text
      find "> .date" card >>= setText current.date
      find ".current .icon" card >>= setClass (getIconClass current.code) true
      find ".current .temperature .value" card >>= (setText $ show current.temp)
      find ".current .sunrise" card >>= setText astronomy.sunrise
      find ".current .sunset" card >>= setText astronomy.sunset
      find ".current .humidity" card >>= (setText $ show humidity <> "%")
      find ".current .wind .value" card >>= (setText $ show wind.speed)
      find ".current .wind .direction" card >>= (setText $ show wind.direction)

      nextDays <- find ".future .oneday" card >>= toArray
      ndw <- nextDaysOfWeek
      foreachE (zip3 nextDays forcast ndw) updateNextDay

      AppState state <- readRef stateRef
      when state.isLoading do
        hide state.spinner
        modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

      where
        channel = cardData.channel
        astronomy = channel.astronomy
        current = channel.item.condition
        forcast = channel.item.forecast
        humidity = channel.atmosphere.humidity
        wind = channel.wind

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t = do
  find ".icon" c >>= setClass (getIconClass daily.code) true
  find ".date" c >>= setText wd
  find ".temp-high .value" c >>= (setText $ show daily.high)
  find ".temp-low .value" c >>= (setText $ show daily.low)
  where
    c = get1 t
    daily = get2 t
    wd = get3 t

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

addSelectedCity :: forall e
   . Ref AppState
  -> JQuery
  -> JQuery
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         , storage :: STORAGE
         | e) Unit
addSelectedCity stateRef citiesSelect addDialog = do
  selectedOpt <- find "option:selected" citiesSelect
  label <- getText selectedOpt
  value <- getValue selectedOpt
  case runExcept $ readString value of
    Left err -> log $ show err
    Right key -> do
      getForecast stateRef key label
      modifyRef stateRef $ storeSelectedCity $ SelectedCity { key, label }
      saveSelectedCities stateRef
      toggleAddDialog false addDialog

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

storeSelectedCity :: SelectedCity -> AppState -> AppState
storeSelectedCity city (AppState state) =
  AppState state { selectedCities = snoc state.selectedCities city }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }


Improved access file actions interaction

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Listing.Item.Component where

import Prelude

import Control.Monad.Aff (attempt)
import Control.MonadPlus (guard)

import Data.Either (either)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Lens (LensP(), lens, (%~), (.~))
import Data.Maybe (Maybe(..))

import Halogen
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Quasar.Aff as API

import SlamData.FileSystem.Effects (Slam())
import SlamData.FileSystem.Listing.Item (Item(..), itemResource)
import SlamData.FileSystem.Resource (Resource(..), resourceName, resourcePath, isDatabase, isFile, isNotebook, isViewMount, hiddenTopLevel, root)
import SlamData.Render.CSS as Rc

type State =
  { item :: Item
  , isSearching :: Boolean
  , isHidden :: Boolean
  , mbURI :: Maybe String
  }

initialState :: State
initialState =
  { item: PhantomItem root
  , isSearching: false
  , isHidden: false
  , mbURI: Nothing
  }

_item :: LensP State Item
_item = lens _.item _{item = _}

_isSearching :: LensP State Boolean
_isSearching = lens _.isSearching _{isSearching = _}

_isHidden :: LensP State Boolean
_isHidden = lens _.isHidden _{isHidden = _}

_mbURI :: LensP State (Maybe String)
_mbURI = lens _.mbURI _{mbURI = _}

data Query a
  = Toggle a
  | Deselect a
  | Open a
  | Configure a
  | Move a
  | Download a
  | Remove a
  | Share a
  | GetItem (Item -> a)
  | SetIsSearching Boolean a
  | SetIsHidden Boolean a
  | GetURI (Maybe String -> a)

comp :: Component State Query Slam
comp = component render eval

render :: State -> ComponentHTML Query
render state = case state.item of
  SelectedItem _ -> itemView state true
  Item _ -> itemView state false
  PhantomItem _ ->
    H.div
      [ P.classes [ B.listGroupItem, Rc.phantom ] ]
      [ H.div
          [ P.class_ B.row ]
          [ H.div
              [ P.classes [ B.colXs9, Rc.itemContent ] ]
              [ H.span_
                  [ H.img [ P.src "img/spin.gif" ]
                  , H.text $ itemName state
                  ]
              ]
          ]
      ]
eval :: Eval Query State Query Slam
eval (Toggle next) = modify (_item %~ toggle) $> next
  where
  toggle (Item r) = SelectedItem r
  toggle (SelectedItem r) = Item r
  toggle it = it
eval (Deselect next) = modify (_item %~ deselect) $> next
  where
  deselect (SelectedItem r) = Item r
  deselect it = it
eval (Open next) = pure next
eval (Configure next) = do
  res <- gets (_.item >>> itemResource)
  uri <- liftAff $ attempt $ API.mountInfo res
  modify (_mbURI .~ either (const Nothing) Just uri) $> next
eval (Move next) = pure next
eval (Download next) = pure next
eval (Remove next) = pure next
eval (Share next) = pure next
eval (GetItem continue) = continue <$> gets _.item
eval (SetIsSearching bool next) = modify (_isSearching .~ bool) $> next
eval (SetIsHidden bool next) = modify (_isHidden .~ bool) $> next
eval (GetURI continue) = continue <$> gets _.mbURI

itemName :: State -> String
itemName { isSearching, item } =
  let toName = if isSearching then resourcePath else resourceName
  in toName $ itemResource item

itemIsHidden :: Item -> Boolean
itemIsHidden = hiddenTopLevel <<< itemResource

presentHiddenItem :: State -> Boolean
presentHiddenItem = not <<< _.isHidden

presentItem :: State -> Item -> Boolean
presentItem state item = (isHidden && presentHiddenItem state) || not isHidden
  where
  isHidden = itemIsHidden item

itemView :: forall p. State -> Boolean -> HTML p Query
itemView state@{ item } selected | not (presentItem state item) = H.text ""
itemView state@{ item } selected | otherwise =
  H.a
    [ P.classes itemClasses
    , E.onClick (E.input_ Toggle)
    , E.onDoubleClick (E.input_ Open)
    , ARIA.label label
    , P.title label
    ]
    [ H.div
        [ P.class_ B.row ]
        [ H.div [ P.classes [ B.colXs9, Rc.itemContent ] ]
            [ H.a
                [ E.onClick $ const (E.preventDefault $> action Open)
                ]
                [ H.span_
                    [ H.i [ iconClasses item ] []
                    , H.text $ itemName state
                    ]
                ]
            ]
        , H.div
            [ P.classes $ [ B.colXs3, Rc.itemToolbar ] <> (guard selected $> Rc.selected) ]
            [ itemActions selected item ]
        ]
    ]
  where
  itemClasses :: Array H.ClassName
  itemClasses =
    [ B.listGroupItem ]
    <> (guard selected $> B.listGroupItemInfo)
    <> (if itemIsHidden item && presentHiddenItem state then [ Rc.itemHidden ] else [ ])

  label :: String
  label | selected = "Hide actions for " ++ itemName state
  label | otherwise  = "Access actions for " ++ itemName state

iconClasses :: forall r i. Item -> P.IProp (class :: P.I | r) i
iconClasses item = P.classes
  [ B.glyphicon
  , Rc.itemIcon
  , iconClass (itemResource item)
  ]
  where
  iconClass :: Resource -> H.ClassName
  iconClass (File _) = B.glyphiconFile
  iconClass (Notebook _) = B.glyphiconBook
  iconClass (Directory _) = B.glyphiconFolderOpen
  iconClass (Database _) = B.glyphiconHdd
  iconClass (ViewMount _) = B.glyphiconFile

itemActions :: forall p. Boolean -> Item -> HTML p Query
itemActions presentActions item | not presentActions = H.text ""
itemActions presentActions item | otherwise =
  H.ul
    [ P.classes [ B.listInline, B.pullRight ]
    , CSS.style $ marginBottom (px zero)
    ]
    (conf <> common <> share)
  where
  r :: Resource
  r = itemResource item

  conf :: Array (HTML p Query)
  conf = guard (isDatabase r) $>
    itemAction Configure "Configure" B.glyphiconWrench

  common :: Array (HTML p Query)
  common =
    [ itemAction Move "Move / rename" B.glyphiconMove
    , itemAction Download "Download" B.glyphiconCloudDownload
    , itemAction Remove "Remove" B.glyphiconTrash
    ]

  share :: Array (HTML p Query)
  share = guard (isFile r || isNotebook r || isViewMount r) $>
    itemAction Share "Share" B.glyphiconShare

  itemAction :: Action Query -> String -> H.ClassName -> HTML p Query
  itemAction act label cls =
    H.li_
      [ H.button
          [ E.onClick (E.input_ act)
          , Cp.mbDoubleClick $ const (E.stopPropagation $> Nothing)
          , P.title label
          , ARIA.label label
          ]
          [ H.i [ P.title label, P.classes [ B.glyphicon, cls ] ] [] ]
      ]

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Listing.Item.Component where

import Prelude

import Control.Monad.Aff (attempt)
import Control.MonadPlus (guard)

import Data.Either (either)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Lens (LensP(), lens, (%~), (.~))
import Data.Maybe (Maybe(..))

import Halogen
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Quasar.Aff as API

import SlamData.FileSystem.Effects (Slam())
import SlamData.FileSystem.Listing.Item (Item(..), itemResource)
import SlamData.FileSystem.Resource (Resource(..), resourceName, resourcePath, isDatabase, isFile, isNotebook, isViewMount, hiddenTopLevel, root)
import SlamData.Render.CSS as Rc

type State =
  { item :: Item
  , isSearching :: Boolean
  , isHidden :: Boolean
  , mbURI :: Maybe String
  }

initialState :: State
initialState =
  { item: PhantomItem root
  , isSearching: false
  , isHidden: false
  , mbURI: Nothing
  }

_item :: LensP State Item
_item = lens _.item _{item = _}

_isSearching :: LensP State Boolean
_isSearching = lens _.isSearching _{isSearching = _}

_isHidden :: LensP State Boolean
_isHidden = lens _.isHidden _{isHidden = _}

_mbURI :: LensP State (Maybe String)
_mbURI = lens _.mbURI _{mbURI = _}

data Query a
  = Toggle a
  | Deselect a
  | Open a
  | Configure a
  | Move a
  | Download a
  | Remove a
  | Share a
  | GetItem (Item -> a)
  | SetIsSearching Boolean a
  | SetIsHidden Boolean a
  | GetURI (Maybe String -> a)

comp :: Component State Query Slam
comp = component render eval

render :: State -> ComponentHTML Query
render state = case state.item of
  SelectedItem _ -> itemView state true
  Item _ -> itemView state false
  PhantomItem _ ->
    H.div
      [ P.classes [ B.listGroupItem, Rc.phantom ] ]
      [ H.div
          [ P.class_ B.row ]
          [ H.div
              [ P.classes [ B.colXs9, Rc.itemContent ] ]
              [ H.span_
                  [ H.img [ P.src "img/spin.gif" ]
                  , H.text $ itemName state
                  ]
              ]
          ]
      ]
eval :: Eval Query State Query Slam
eval (Toggle next) = modify (_item %~ toggle) $> next
  where
  toggle (Item r) = SelectedItem r
  toggle (SelectedItem r) = Item r
  toggle it = it
eval (Deselect next) = modify (_item %~ deselect) $> next
  where
  deselect (SelectedItem r) = Item r
  deselect it = it
eval (Open next) = pure next
eval (Configure next) = do
  res <- gets (_.item >>> itemResource)
  uri <- liftAff $ attempt $ API.mountInfo res
  modify (_mbURI .~ either (const Nothing) Just uri) $> next
eval (Move next) = pure next
eval (Download next) = pure next
eval (Remove next) = pure next
eval (Share next) = pure next
eval (GetItem continue) = continue <$> gets _.item
eval (SetIsSearching bool next) = modify (_isSearching .~ bool) $> next
eval (SetIsHidden bool next) = modify (_isHidden .~ bool) $> next
eval (GetURI continue) = continue <$> gets _.mbURI

itemName :: State -> String
itemName { isSearching, item } =
  let toName = if isSearching then resourcePath else resourceName
  in toName $ itemResource item

itemView :: forall p. State -> Boolean -> HTML p Query
itemView state@{ item } selected =
  H.div
    [ P.classes itemClasses
    , E.onClick (E.input_ Toggle)
    , E.onDoubleClick (E.input_ Open)
    ]
    [ H.div
        [ P.class_ B.row ]
        [ H.div [ P.classes [ B.colXs9, Rc.itemContent ] ]
            [ H.a [ E.onClick $ const (E.preventDefault $> action Open) ]
                [ H.span_
                    [ H.i [ iconClasses item ] []
                    , H.text $ itemName state
                    ]
                ]
            ]
        , H.a
            [ P.classes
                 $ [ B.colXs3, Rc.itemToolbar, Rc.selected ]
            ]
            [ H.ul
                [ P.classes [ B.listInline, B.pullRight ]
                , CSS.style $ marginBottom (px zero)
                ]
                $ toolbar item
            ]
        ]
    ]
  where
  itemClasses :: Array H.ClassName
  itemClasses =
    [ B.listGroupItem ]
    <> (guard selected $> B.listGroupItemInfo)
    <> (if hiddenTopLevel (itemResource item)
        then if state.isHidden
             then [ B.hidden ]
             else [ Rc.itemHidden ]
        else [ ])

iconClasses :: forall r i. Item -> P.IProp (class :: P.I | r) i
iconClasses item = P.classes
  [ B.glyphicon
  , Rc.itemIcon
  , iconClass (itemResource item)
  ]
  where
  iconClass :: Resource -> H.ClassName
  iconClass (File _) = B.glyphiconFile
  iconClass (Notebook _) = B.glyphiconBook
  iconClass (Directory _) = B.glyphiconFolderOpen
  iconClass (Database _) = B.glyphiconHdd
  iconClass (ViewMount _) = B.glyphiconFile

toolbar :: forall p. Item -> Array (HTML p Query)
toolbar it = conf <> common <> share
  where
  r :: Resource
  r = itemResource it

  conf :: Array (HTML p Query)
  conf = guard (isDatabase r) $>
    toolItem Configure "Configure" B.glyphiconWrench

  common :: Array (HTML p Query)
  common =
    [ toolItem Move "Move / rename" B.glyphiconMove
    , toolItem Download "Download" B.glyphiconCloudDownload
    , toolItem Remove "Remove" B.glyphiconTrash
    ]

  share :: Array (HTML p Query)
  share = guard (isFile r || isNotebook r || isViewMount r) $>
    toolItem Share "Share" B.glyphiconShare

  toolItem :: Action Query -> String -> H.ClassName -> HTML p Query
  toolItem act label cls =
    H.li_
      [ H.button
          [ E.onClick (E.input_ act)
          , Cp.mbDoubleClick $ const (E.stopPropagation $> Nothing)
          , P.title label
          , ARIA.label label
          ]
          [ H.i [ P.title label, P.classes [ B.glyphicon, cls ] ] [] ]
      ]


remove `bimap id id`

remove `bimap id id`

module Component.Task where

import Prelude

import Control.Monad.State as CMS

import Data.Bifunctor (bimap)
import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import Model (Task)

-- | The task component query algebra.
data TaskQuery a
  = UpdateDescription String a
  | ToggleCompleted Boolean a
  | Remove a
  | IsCompleted (Boolean -> a)

data TaskMessage
  = NotifyRemove
  | Toggled Boolean

-- | The task component definition.
task :: forall m. Task -> H.Component HH.HTML TaskQuery Unit TaskMessage m
task initialState =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  render :: Task -> H.ComponentHTML TaskQuery
  render t =
    HH.li_
      [ HH.input
          [ HP.type_ HP.InputCheckbox
          , HP.title "Mark as completed"
          , HP.checked t.completed
          , HE.onChecked (HE.input ToggleCompleted)
          ]
      , HH.input
          [ HP.type_ HP.InputText
          , HP.placeholder "Task description"
          , HP.autofocus true
          , HP.value t.description
          , HE.onValueChange (HE.input UpdateDescription)
          ]
      , HH.button
          [ HP.title "Remove task"
          , HE.onClick (HE.input_ Remove)
          ]
          [ HH.text "✖" ]
      ]

  eval :: TaskQuery ~> H.ComponentDSL Task TaskQuery TaskMessage m
  eval (UpdateDescription desc next) = do
    CMS.modify (_ { description = desc })
    pure next
  eval (ToggleCompleted b next) = do
    CMS.modify (_ { completed = b })
    H.raise (Toggled b)
    pure next
  eval (Remove next) = do
    H.raise NotifyRemove
    pure next
  eval (IsCompleted reply) = do
    b <- CMS.gets (_.completed)
    pure (reply b)

module Component.Task where

import Prelude

import Control.Monad.State as CMS

import Data.Bifunctor (bimap)
import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import Model (Task)

-- | The task component query algebra.
data TaskQuery a
  = UpdateDescription String a
  | ToggleCompleted Boolean a
  | Remove a
  | IsCompleted (Boolean -> a)

data TaskMessage
  = NotifyRemove
  | Toggled Boolean

-- | The task component definition.
task :: forall m. Task -> H.Component HH.HTML TaskQuery Unit TaskMessage m
task initialState =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  render :: Task -> H.ComponentHTML TaskQuery
  render t =
    bimap id id $ HH.li_
      [ HH.input
          [ HP.type_ HP.InputCheckbox
          , HP.title "Mark as completed"
          , HP.checked t.completed
          , HE.onChecked (HE.input ToggleCompleted)
          ]
      , HH.input
          [ HP.type_ HP.InputText
          , HP.placeholder "Task description"
          , HP.autofocus true
          , HP.value t.description
          , HE.onValueChange (HE.input UpdateDescription)
          ]
      , HH.button
          [ HP.title "Remove task"
          , HE.onClick (HE.input_ Remove)
          ]
          [ HH.text "✖" ]
      ]

  eval :: TaskQuery ~> H.ComponentDSL Task TaskQuery TaskMessage m
  eval (UpdateDescription desc next) = do
    CMS.modify (_ { description = desc })
    pure next
  eval (ToggleCompleted b next) = do
    CMS.modify (_ { completed = b })
    H.raise (Toggled b)
    pure next
  eval (Remove next) = do
    H.raise NotifyRemove
    pure next
  eval (IsCompleted reply) = do
    b <- CMS.gets (_.completed)
    pure (reply b)


Update `Field` (refs #132)

Update `Field` (refs #132)

Fix superclasses and expand documentation.

module Data.Field
  ( class Field
  , module Data.DivisionRing
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.DivisionRing (class DivisionRing, recip)
import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/), gcd, lcm)
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `Field` class is for types that are (commutative) fields.
-- |
-- | Mathematically, a field is a ring which is commutative and in which every
-- | nonzero element has a multiplicative inverse; these conditions correspond
-- | to the `CommutativeRing` and `DivisionRing` classes in PureScript
-- | respectively. However, the `Field` class has `EuclideanRing` and
-- | `DivisionRing` as superclasses, which seems like a stronger requirement
-- | (since `CommutativeRing` is a superclass of `EuclideanRing`). In fact, it
-- | is not stronger, since any type which has law-abiding `CommutativeRing`
-- | and `DivisionRing` instances permits exactly one law-abiding
-- | `EuclideanRing` instance. We use a `EuclideanRing` superclass here in
-- | order to ensure that a `Field` constraint on a function permits you to use
-- | `div` on that type, since `div` is a member of `EuclideanRing`.
-- |
-- | This class has no laws or members of its own; it exists as a convenience,
-- | so a single constraint can be used when field-like behaviour is expected.
-- |
-- | This module also defines a single `Field` instance for any type which has
-- | both `EuclideanRing` and `DivisionRing` instances. Any other instance
-- | would overlap with this instance, so no other `Field` instances should be
-- | defined in libraries. Instead, simply define `EuclideanRing` and
-- | `DivisionRing` instances, and this will permit your type to be used with a
-- | `Field` constraint.
class (EuclideanRing a, DivisionRing a) <= Field a

instance field :: (EuclideanRing a, DivisionRing a) => Field a

module Data.Field
  ( class Field
  , module Data.DivisionRing
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.DivisionRing (class DivisionRing, recip)
import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/), gcd, lcm)
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `Field` class is for types that are (commutative) fields.
-- |
-- | `Field`s are exactly `EuclideanRing` + `CommutativeRing` so this class
-- | exists as a convenience, so a single constraint can be used when field-like
-- | behaviour is expected.
class (EuclideanRing a, CommutativeRing a) <= Field a

instance fieldNumber :: (EuclideanRing a, CommutativeRing a) => Field a


Change types in traverseArrayImpl to be more truthful. (#142)

module Data.Traversable
  ( class Traversable, traverse, sequence
  , traverseDefault, sequenceDefault
  , for
  , scanl
  , scanr
  , mapAccumL
  , mapAccumR
  , module Data.Foldable
  , module Data.Traversable.Accum
  ) where

import Prelude

import Control.Apply (lift2)
import Data.Const (Const(..))
import Data.Either (Either(..))
import Data.Foldable (class Foldable, all, and, any, elem, find, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, for_, intercalate, maximum, maximumBy, minimum, minimumBy, notElem, oneOf, or, sequence_, sum, traverse_)
import Data.Functor.App (App(..))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct(..), coproduct)
import Data.Functor.Product (Product(..), product)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Traversable.Accum (Accum)
import Data.Traversable.Accum.Internal (StateL(..), StateR(..), stateL, stateR)
import Data.Tuple (Tuple(..))

-- | `Traversable` represents data structures which can be _traversed_,
-- | accumulating results and effects in some `Applicative` functor.
-- |
-- | - `traverse` runs an action for every element in a data structure,
-- |   and accumulates the results.
-- | - `sequence` runs the actions _contained_ in a data structure,
-- |   and accumulates the results.
-- |
-- | ```purescript
-- | import Data.Traversable
-- | import Data.Maybe
-- | import Data.Int (fromNumber)
-- |
-- | sequence [Just 1, Just 2, Just 3] == Just [1,2,3]
-- | sequence [Nothing, Just 2, Just 3] == Nothing
-- |
-- | traverse fromNumber [1.0, 2.0, 3.0] == Just [1,2,3]
-- | traverse fromNumber [1.5, 2.0, 3.0] == Nothing
-- |
-- | traverse logShow [1,2,3]
-- | -- prints:
-- |    1
-- |    2
-- |    3
-- |
-- | traverse (\x -> [x, 0]) [1,2,3] == [[1,2,3],[1,2,0],[1,0,3],[1,0,0],[0,2,3],[0,2,0],[0,0,3],[0,0,0]]
-- | ```
-- |
-- | The `traverse` and `sequence` functions should be compatible in the
-- | following sense:
-- |
-- | - `traverse f xs = sequence (f <$> xs)`
-- | - `sequence = traverse identity`
-- |
-- | `Traversable` instances should also be compatible with the corresponding
-- | `Foldable` instances, in the following sense:
-- |
-- | - `foldMap f = runConst <<< traverse (Const <<< f)`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `traverseDefault`
-- | - `sequenceDefault`
class (Functor t, Foldable t) <= Traversable t where
  traverse :: forall a b m. Applicative m => (a -> m b) -> t a -> m (t b)
  sequence :: forall a m. Applicative m => t (m a) -> m (t a)

-- | A default implementation of `traverse` using `sequence` and `map`.
traverseDefault
  :: forall t a b m
   . Traversable t
  => Applicative m
  => (a -> m b)
  -> t a
  -> m (t b)
traverseDefault f ta = sequence (f <$> ta)

-- | A default implementation of `sequence` using `traverse`.
sequenceDefault
  :: forall t a m
   . Traversable t
  => Applicative m
  => t (m a)
  -> m (t a)
sequenceDefault = traverse identity

instance traversableArray :: Traversable Array where
  traverse = traverseArrayImpl apply map pure
  sequence = sequenceDefault

foreign import traverseArrayImpl
  :: forall m a b
   . (forall x y. m (x -> y) -> m x -> m y)
  -> (forall x y. (x -> y) -> m x -> m y)
  -> (forall x. x -> m x)
  -> (a -> m b)
  -> Array a
  -> m (Array b)

instance traversableMaybe :: Traversable Maybe where
  traverse _ Nothing  = pure Nothing
  traverse f (Just x) = Just <$> f x
  sequence Nothing  = pure Nothing
  sequence (Just x) = Just <$> x

instance traversableFirst :: Traversable First where
  traverse f (First x) = First <$> traverse f x
  sequence (First x) = First <$> sequence x

instance traversableLast :: Traversable Last where
  traverse f (Last x) = Last <$> traverse f x
  sequence (Last x) = Last <$> sequence x

instance traversableAdditive :: Traversable Additive where
  traverse f (Additive x) = Additive <$> f x
  sequence (Additive x) = Additive <$> x

instance traversableDual :: Traversable Dual where
  traverse f (Dual x) = Dual <$> f x
  sequence (Dual x) = Dual <$> x

instance traversableConj :: Traversable Conj where
  traverse f (Conj x) = Conj <$> f x
  sequence (Conj x) = Conj <$> x

instance traversableDisj :: Traversable Disj where
  traverse f (Disj x) = Disj <$> f x
  sequence (Disj x) = Disj <$> x

instance traversableMultiplicative :: Traversable Multiplicative where
  traverse f (Multiplicative x) = Multiplicative <$> f x
  sequence (Multiplicative x) = Multiplicative <$> x

instance traversableEither :: Traversable (Either a) where
  traverse _ (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x
  sequence (Left x) = pure (Left x)
  sequence (Right x)  = Right <$> x

instance traversableTuple :: Traversable (Tuple a) where
  traverse f (Tuple x y) = Tuple x <$> f y
  sequence (Tuple x y) = Tuple x <$> y

instance traversableIdentity :: Traversable Identity where
  traverse f (Identity x) = Identity <$> f x
  sequence (Identity x) = Identity <$> x

instance traversableConst :: Traversable (Const a) where
  traverse _ (Const x) = pure (Const x)
  sequence (Const x) = pure (Const x)

instance traversableProduct :: (Traversable f, Traversable g) => Traversable (Product f g) where
  traverse f (Product (Tuple fa ga)) = lift2 product (traverse f fa) (traverse f ga)
  sequence (Product (Tuple fa ga)) = lift2 product (sequence fa) (sequence ga)

instance traversableCoproduct :: (Traversable f, Traversable g) => Traversable (Coproduct f g) where
  traverse f = coproduct
    (map (Coproduct <<< Left) <<< traverse f)
    (map (Coproduct <<< Right) <<< traverse f)
  sequence = coproduct
    (map (Coproduct <<< Left) <<< sequence)
    (map (Coproduct <<< Right) <<< sequence)

instance traversableCompose :: (Traversable f, Traversable g) => Traversable (Compose f g) where
  traverse f (Compose fga) = map Compose $ traverse (traverse f) fga
  sequence = traverse identity

instance traversableApp :: Traversable f => Traversable (App f) where
  traverse f (App x) = App <$> traverse f x
  sequence (App x) = App <$> sequence x

-- | A version of `traverse` with its arguments flipped.
-- |
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for [1, 2, 3] \n -> do
-- |   print n
-- |   return (n * n)
-- | ```
for
  :: forall a b m t
   . Applicative m
  => Traversable t
  => t a
  -> (a -> m b)
  -> m (t b)
for x f = traverse f x

-- | Fold a data structure from the left, keeping all intermediate results
-- | instead of only the final result. Note that the initial value does not
-- | appear in the result (unlike Haskell's `Prelude.scanl`).
-- |
-- | ```purescript
-- | scanl (+) 0  [1,2,3] = [1,3,6]
-- | scanl (-) 10 [1,2,3] = [9,7,4]
-- | ```
scanl :: forall a b f. Traversable f => (b -> a -> b) -> b -> f a -> f b
scanl f b0 xs = (mapAccumL (\b a -> let b' = f b a in { accum: b', value: b' }) b0 xs).value

-- | Fold a data structure from the left, keeping all intermediate results
-- | instead of only the final result.
-- |
-- | Unlike `scanl`, `mapAccumL` allows the type of accumulator to differ
-- | from the element type of the final data structure.
mapAccumL
  :: forall a b s f
   . Traversable f
  => (s -> a -> Accum s b)
  -> s
  -> f a
  -> Accum s (f b)
mapAccumL f s0 xs = stateL (traverse (\a -> StateL \s -> f s a) xs) s0

-- | Fold a data structure from the right, keeping all intermediate results
-- | instead of only the final result. Note that the initial value does not
-- | appear in the result (unlike Haskell's `Prelude.scanr`).
-- |
-- | ```purescript
-- | scanr (+) 0 [1,2,3] = [6,5,3]
-- | scanr (flip (-)) 10 [1,2,3] = [4,5,7]
-- | ```
scanr :: forall a b f. Traversable f => (a -> b -> b) -> b -> f a -> f b
scanr f b0 xs = (mapAccumR (\b a -> let b' = f a b in { accum: b', value: b' }) b0 xs).value

-- | Fold a data structure from the right, keeping all intermediate results
-- | instead of only the final result.
-- |
-- | Unlike `scanr`, `mapAccumR` allows the type of accumulator to differ
-- | from the element type of the final data structure.
mapAccumR
  :: forall a b s f
   . Traversable f
  => (s -> a -> Accum s b)
  -> s
  -> f a
  -> Accum s (f b)
mapAccumR f s0 xs = stateR (traverse (\a -> StateR \s -> f s a) xs) s0

module Data.Traversable
  ( class Traversable, traverse, sequence
  , traverseDefault, sequenceDefault
  , for
  , scanl
  , scanr
  , mapAccumL
  , mapAccumR
  , module Data.Foldable
  , module Data.Traversable.Accum
  ) where

import Prelude

import Control.Apply (lift2)
import Data.Const (Const(..))
import Data.Either (Either(..))
import Data.Foldable (class Foldable, all, and, any, elem, find, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, for_, intercalate, maximum, maximumBy, minimum, minimumBy, notElem, oneOf, or, sequence_, sum, traverse_)
import Data.Functor.App (App(..))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct(..), coproduct)
import Data.Functor.Product (Product(..), product)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Traversable.Accum (Accum)
import Data.Traversable.Accum.Internal (StateL(..), StateR(..), stateL, stateR)
import Data.Tuple (Tuple(..))

-- | `Traversable` represents data structures which can be _traversed_,
-- | accumulating results and effects in some `Applicative` functor.
-- |
-- | - `traverse` runs an action for every element in a data structure,
-- |   and accumulates the results.
-- | - `sequence` runs the actions _contained_ in a data structure,
-- |   and accumulates the results.
-- |
-- | ```purescript
-- | import Data.Traversable
-- | import Data.Maybe
-- | import Data.Int (fromNumber)
-- |
-- | sequence [Just 1, Just 2, Just 3] == Just [1,2,3]
-- | sequence [Nothing, Just 2, Just 3] == Nothing
-- |
-- | traverse fromNumber [1.0, 2.0, 3.0] == Just [1,2,3]
-- | traverse fromNumber [1.5, 2.0, 3.0] == Nothing
-- |
-- | traverse logShow [1,2,3]
-- | -- prints:
-- |    1
-- |    2
-- |    3
-- |
-- | traverse (\x -> [x, 0]) [1,2,3] == [[1,2,3],[1,2,0],[1,0,3],[1,0,0],[0,2,3],[0,2,0],[0,0,3],[0,0,0]]
-- | ```
-- |
-- | The `traverse` and `sequence` functions should be compatible in the
-- | following sense:
-- |
-- | - `traverse f xs = sequence (f <$> xs)`
-- | - `sequence = traverse identity`
-- |
-- | `Traversable` instances should also be compatible with the corresponding
-- | `Foldable` instances, in the following sense:
-- |
-- | - `foldMap f = runConst <<< traverse (Const <<< f)`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `traverseDefault`
-- | - `sequenceDefault`
class (Functor t, Foldable t) <= Traversable t where
  traverse :: forall a b m. Applicative m => (a -> m b) -> t a -> m (t b)
  sequence :: forall a m. Applicative m => t (m a) -> m (t a)

-- | A default implementation of `traverse` using `sequence` and `map`.
traverseDefault
  :: forall t a b m
   . Traversable t
  => Applicative m
  => (a -> m b)
  -> t a
  -> m (t b)
traverseDefault f ta = sequence (f <$> ta)

-- | A default implementation of `sequence` using `traverse`.
sequenceDefault
  :: forall t a m
   . Traversable t
  => Applicative m
  => t (m a)
  -> m (t a)
sequenceDefault = traverse identity

instance traversableArray :: Traversable Array where
  traverse = traverseArrayImpl apply map pure
  sequence = sequenceDefault

foreign import traverseArrayImpl
  :: forall m a b
   . (m (a -> b) -> m a -> m b)
  -> ((a -> b) -> m a -> m b)
  -> (a -> m a)
  -> (a -> m b)
  -> Array a
  -> m (Array b)

instance traversableMaybe :: Traversable Maybe where
  traverse _ Nothing  = pure Nothing
  traverse f (Just x) = Just <$> f x
  sequence Nothing  = pure Nothing
  sequence (Just x) = Just <$> x

instance traversableFirst :: Traversable First where
  traverse f (First x) = First <$> traverse f x
  sequence (First x) = First <$> sequence x

instance traversableLast :: Traversable Last where
  traverse f (Last x) = Last <$> traverse f x
  sequence (Last x) = Last <$> sequence x

instance traversableAdditive :: Traversable Additive where
  traverse f (Additive x) = Additive <$> f x
  sequence (Additive x) = Additive <$> x

instance traversableDual :: Traversable Dual where
  traverse f (Dual x) = Dual <$> f x
  sequence (Dual x) = Dual <$> x

instance traversableConj :: Traversable Conj where
  traverse f (Conj x) = Conj <$> f x
  sequence (Conj x) = Conj <$> x

instance traversableDisj :: Traversable Disj where
  traverse f (Disj x) = Disj <$> f x
  sequence (Disj x) = Disj <$> x

instance traversableMultiplicative :: Traversable Multiplicative where
  traverse f (Multiplicative x) = Multiplicative <$> f x
  sequence (Multiplicative x) = Multiplicative <$> x

instance traversableEither :: Traversable (Either a) where
  traverse _ (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x
  sequence (Left x) = pure (Left x)
  sequence (Right x)  = Right <$> x

instance traversableTuple :: Traversable (Tuple a) where
  traverse f (Tuple x y) = Tuple x <$> f y
  sequence (Tuple x y) = Tuple x <$> y

instance traversableIdentity :: Traversable Identity where
  traverse f (Identity x) = Identity <$> f x
  sequence (Identity x) = Identity <$> x

instance traversableConst :: Traversable (Const a) where
  traverse _ (Const x) = pure (Const x)
  sequence (Const x) = pure (Const x)

instance traversableProduct :: (Traversable f, Traversable g) => Traversable (Product f g) where
  traverse f (Product (Tuple fa ga)) = lift2 product (traverse f fa) (traverse f ga)
  sequence (Product (Tuple fa ga)) = lift2 product (sequence fa) (sequence ga)

instance traversableCoproduct :: (Traversable f, Traversable g) => Traversable (Coproduct f g) where
  traverse f = coproduct
    (map (Coproduct <<< Left) <<< traverse f)
    (map (Coproduct <<< Right) <<< traverse f)
  sequence = coproduct
    (map (Coproduct <<< Left) <<< sequence)
    (map (Coproduct <<< Right) <<< sequence)

instance traversableCompose :: (Traversable f, Traversable g) => Traversable (Compose f g) where
  traverse f (Compose fga) = map Compose $ traverse (traverse f) fga
  sequence = traverse identity

instance traversableApp :: Traversable f => Traversable (App f) where
  traverse f (App x) = App <$> traverse f x
  sequence (App x) = App <$> sequence x

-- | A version of `traverse` with its arguments flipped.
-- |
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for [1, 2, 3] \n -> do
-- |   print n
-- |   return (n * n)
-- | ```
for
  :: forall a b m t
   . Applicative m
  => Traversable t
  => t a
  -> (a -> m b)
  -> m (t b)
for x f = traverse f x

-- | Fold a data structure from the left, keeping all intermediate results
-- | instead of only the final result. Note that the initial value does not
-- | appear in the result (unlike Haskell's `Prelude.scanl`).
-- |
-- | ```purescript
-- | scanl (+) 0  [1,2,3] = [1,3,6]
-- | scanl (-) 10 [1,2,3] = [9,7,4]
-- | ```
scanl :: forall a b f. Traversable f => (b -> a -> b) -> b -> f a -> f b
scanl f b0 xs = (mapAccumL (\b a -> let b' = f b a in { accum: b', value: b' }) b0 xs).value

-- | Fold a data structure from the left, keeping all intermediate results
-- | instead of only the final result.
-- |
-- | Unlike `scanl`, `mapAccumL` allows the type of accumulator to differ
-- | from the element type of the final data structure.
mapAccumL
  :: forall a b s f
   . Traversable f
  => (s -> a -> Accum s b)
  -> s
  -> f a
  -> Accum s (f b)
mapAccumL f s0 xs = stateL (traverse (\a -> StateL \s -> f s a) xs) s0

-- | Fold a data structure from the right, keeping all intermediate results
-- | instead of only the final result. Note that the initial value does not
-- | appear in the result (unlike Haskell's `Prelude.scanr`).
-- |
-- | ```purescript
-- | scanr (+) 0 [1,2,3] = [6,5,3]
-- | scanr (flip (-)) 10 [1,2,3] = [4,5,7]
-- | ```
scanr :: forall a b f. Traversable f => (a -> b -> b) -> b -> f a -> f b
scanr f b0 xs = (mapAccumR (\b a -> let b' = f a b in { accum: b', value: b' }) b0 xs).value

-- | Fold a data structure from the right, keeping all intermediate results
-- | instead of only the final result.
-- |
-- | Unlike `scanr`, `mapAccumR` allows the type of accumulator to differ
-- | from the element type of the final data structure.
mapAccumR
  :: forall a b s f
   . Traversable f
  => (s -> a -> Accum s b)
  -> s
  -> f a
  -> Accum s (f b)
mapAccumR f s0 xs = stateR (traverse (\a -> StateR \s -> f s a) xs) s0


Add "char" to Char mapping

Add "char" to Char mapping

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foreign (Foreign, readArray, readChar, readString, toForeign)
import Data.List (List)
import Data.List as List
import Data.Maybe (fromJust, Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Partial.Unsafe (unsafePartial)
import Prelude

foreign import data POSTGRESQL :: !

type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

foreign import data Pool :: *

foreign import data Connection :: *

newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

class ToSQLValue a where
    toSQLValue :: a -> Foreign

class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple1 :: (ToSQLValue a) => ToSQLRow (Tuple a Unit) where
    toSQLRow (a /\ _) = [toSQLValue a]

instance toSQLRowTuple2 :: (ToSQLValue a, ToSQLValue b) => ToSQLRow (Tuple a (Tuple b Unit)) where
    toSQLRow (a /\ b /\ _) = [toSQLValue a, toSQLValue b]

instance toSQLRowTuple3 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c) => ToSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    toSQLRow (a /\ b /\ c /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c]

instance toSQLRowTuple4 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    toSQLRow (a /\ b /\ c /\ d /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d]

instance toSQLRowTuple5 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d, ToSQLValue e) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    toSQLRow (a /\ b /\ c /\ d /\ e /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d, toSQLValue e]

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = fromRight <<< runExcept <<< readChar

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    <#> map (unsafePartial fromJust <<< fromSQLRow)

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foreign (Foreign, readArray, readString, toForeign)
import Data.List (List)
import Data.List as List
import Data.Maybe (fromJust, Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Partial.Unsafe (unsafePartial)
import Prelude

foreign import data POSTGRESQL :: !

type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

foreign import data Pool :: *

foreign import data Connection :: *

newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

class ToSQLValue a where
    toSQLValue :: a -> Foreign

class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple1 :: (ToSQLValue a) => ToSQLRow (Tuple a Unit) where
    toSQLRow (a /\ _) = [toSQLValue a]

instance toSQLRowTuple2 :: (ToSQLValue a, ToSQLValue b) => ToSQLRow (Tuple a (Tuple b Unit)) where
    toSQLRow (a /\ b /\ _) = [toSQLValue a, toSQLValue b]

instance toSQLRowTuple3 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c) => ToSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    toSQLRow (a /\ b /\ c /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c]

instance toSQLRowTuple4 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    toSQLRow (a /\ b /\ c /\ d /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d]

instance toSQLRowTuple5 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d, ToSQLValue e) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    toSQLRow (a /\ b /\ c /\ d /\ e /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d, toSQLValue e]

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    <#> map (unsafePartial fromJust <<< fromSQLRow)

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a


Added show instance to the DataPoint

Added show instance to the DataPoint

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data access
    , dpIndex
    , dpValue
    , head
    , index
    , last
    , slice
    , resolution
    , values
    -- Data operations
    , diff
    , integrate
    , filter
    , groupBy
    , length
    , rollingWindow
    , toDataPoints
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Data.TimeSeries.Time (Timestamp)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

-- | Data point is a time indexed value
data DataPoint a = DP Timestamp a

-- | Data structure for holding Series.
data Series a = Series (Array Timestamp) (Array a)

instance showDataPoint :: Show a => Show (DataPoint a) where
    show (DP idx v) = "{ index: " <> show idx <> ", value: " <> show v <> " }"

instance eqDataPoint :: Eq a => Eq (DataPoint a) where
    eq (DP idx1 vs1) (DP idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance showSeries :: Show a => Show (Series a) where
    show (Series idx vs) = "{ index: " <> show idx <> "\n, values: " <> show vs <> "\n}"

instance eqSeries :: Eq a => Eq (Series a) where
    eq (Series idx1 vs1) (Series idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance functorSeries :: Functor Series where
    map f (Series idx vs) = Series idx (map f vs)

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = DP i v

-- | Get DataPoint index
dpIndex :: ∀ a. DataPoint a -> Timestamp
dpIndex (DP i _) = i

-- | Get DataPoint value
dpValue :: ∀ a. DataPoint a -> a
dpValue (DP _ v) = v

-- | Get Series index
index :: ∀ a. Series a -> Array Timestamp
index (Series idx _) = idx

-- | Get Series values
values :: ∀ a. Series a -> Array a
values (Series _ vs) = vs

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = Series is vs

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map dpIndex xs) (map dpValue xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints (Series idx vs) = (\t -> dataPoint (fst t) (snd t)) <$> A.zip idx vs

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length (Series idx vs) = A.length idx

-- | Get first element if exists
head :: ∀ a. Series a -> Maybe (DataPoint a)
head (Series idx vs) = do
    i <- A.head idx
    v <- A.head vs
    pure $ dataPoint i v

-- | Get last element if exists
last :: ∀ a. Series a -> Maybe (DataPoint a)
last (Series idx vs) = do
    i <- A.last idx
    v <- A.last vs
    pure $ dataPoint i v

-- | Get distance between points in this series
resolution :: ∀ a. Series a -> Number
resolution (Series idx _) = if n1 < 1 then 0.0 else (x2-x1) / toNumber n1
    where
        x1 = fromMaybe 0.0 (A.head idx)
        x2 = fromMaybe 0.0 (A.last idx)
        n1 = (A.length idx) - 1

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end (Series idx vs) = series (A.slice i j idx) (A.slice i j vs)
    where
        n = A.length idx
        i = fromMaybe n $ A.findIndex (\x -> x >= start) idx
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) idx

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred (Series idx vs) = series (fst tu) (snd tu)
    where
        -- zip
        xs1 = A.zip idx vs
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        tu = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if (dpIndex y') > (dpIndex x) then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint (dpIndex x) (f (dpValue x) (dpValue y'))))
            where
                ys' = A.dropWhile (\y -> (dpIndex y) < (dpIndex x)) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'

-- | Apply function to the rolling window and create new Series
rollingWindow :: ∀ a b. Int -> (Array a -> b) -> Series a -> Series b
rollingWindow n agg (Series idx vs) = series idx2 $ rolling' (A.take n1 vs) agg (A.drop n1 vs)
    where
        n1 = n-1
        idx2 = A.drop n1 idx

rolling' :: ∀ a b. Array a -> (Array a -> b) -> Array a -> Array b
rolling' mu agg xs = (A.foldl f {wnd: mu, out: []} xs).out
    where
      f {wnd: ws, out: os} x = {wnd: wnd2, out: A.snoc os (agg wnd1)}
        where
            wnd1 = A.snoc ws x
            wnd2 = A.drop 1 wnd1

-- | Differentiate Series xt = xt - x(t-1)
diff :: ∀ a. Ring a => Series a -> Series a
diff (Series idx vs) = Series (A.drop 1 idx) vs2
    where
        vs2 = A.zipWith (-) (A.drop 1 vs) vs

-- | Integrate Series
integrate :: ∀ a. Ring a => Series a -> Series a
integrate (Series idx vs) = Series idx v2
    where
        v2 = snd (A.foldl f (Tuple zero []) vs)
        f (Tuple a os) x = Tuple (a+x) (A.snoc os (a+x))

-- | Group series datapoints. This will reduce series data points number by given n.
groupBy :: ∀ a b. Number    -- ^ Window size in milliseconds
        -> (Array a -> b)   -- ^ Function applied to group values
        -> Series a         -- ^ Input series
        -> Series b         -- ^ Grouped series
groupBy dt f xs = fromDataPoints $ groupBy' dt f (toDataPoints xs)

groupBy' :: ∀ a b. Number -> (Array a -> b) -> Array (DataPoint a) -> Array (DataPoint b)
groupBy' dt f xs = snd $ A.foldl g (Tuple [] []) xs
    where
        g :: Tuple (Array (DataPoint a)) (Array (DataPoint b)) -> DataPoint a -> Tuple (Array (DataPoint a)) (Array (DataPoint b))
        g (Tuple acc out) x = case A.uncons acc of
            Just {head: y, tail} -> if (dpIndex x) < (dpIndex y) + dt
                                    then Tuple (A.snoc acc x) out
                                    else Tuple [x] (A.snoc out (dataPoint (dpIndex y) (f' acc)))
            Nothing -> Tuple [x] out
        f' :: Array (DataPoint a) -> b
        f' ds = f $ map dpValue ds

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data access
    , dpIndex
    , dpValue
    , head
    , index
    , last
    , slice
    , resolution
    , values
    -- Data operations
    , diff
    , integrate
    , filter
    , groupBy
    , length
    , rollingWindow
    , toDataPoints
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Data.TimeSeries.Time (Timestamp)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

-- | Data point is a time indexed value
data DataPoint a = DP Timestamp a

-- | Data structure for holding Series.
data Series a = Series (Array Timestamp) (Array a)

instance eqDataPoint :: Eq a => Eq (DataPoint a) where
    eq (DP idx1 vs1) (DP idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance showSeries :: Show a => Show (Series a) where
    show (Series idx vs) = "{ index: " <> show idx <> "\n, values: " <> show vs <> "\n}"

instance eqSeries :: Eq a => Eq (Series a) where
    eq (Series idx1 vs1) (Series idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance functorSeries :: Functor Series where
    map f (Series idx vs) = Series idx (map f vs)

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = DP i v

-- | Get DataPoint index
dpIndex :: ∀ a. DataPoint a -> Timestamp
dpIndex (DP i _) = i

-- | Get DataPoint value
dpValue :: ∀ a. DataPoint a -> a
dpValue (DP _ v) = v

-- | Get Series index
index :: ∀ a. Series a -> Array Timestamp
index (Series idx _) = idx

-- | Get Series values
values :: ∀ a. Series a -> Array a
values (Series _ vs) = vs

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = Series is vs

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map dpIndex xs) (map dpValue xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints (Series idx vs) = (\t -> dataPoint (fst t) (snd t)) <$> A.zip idx vs

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length (Series idx vs) = A.length idx

-- | Get first element if exists
head :: ∀ a. Series a -> Maybe (DataPoint a)
head (Series idx vs) = do
    i <- A.head idx
    v <- A.head vs
    pure $ dataPoint i v

-- | Get last element if exists
last :: ∀ a. Series a -> Maybe (DataPoint a)
last (Series idx vs) = do
    i <- A.last idx
    v <- A.last vs
    pure $ dataPoint i v

-- | Get distance between points in this series
resolution :: ∀ a. Series a -> Number
resolution (Series idx _) = if n1 < 1 then 0.0 else (x2-x1) / toNumber n1
    where
        x1 = fromMaybe 0.0 (A.head idx)
        x2 = fromMaybe 0.0 (A.last idx)
        n1 = (A.length idx) - 1

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end (Series idx vs) = series (A.slice i j idx) (A.slice i j vs)
    where
        n = A.length idx
        i = fromMaybe n $ A.findIndex (\x -> x >= start) idx
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) idx

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred (Series idx vs) = series (fst tu) (snd tu)
    where
        -- zip
        xs1 = A.zip idx vs
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        tu = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if (dpIndex y') > (dpIndex x) then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint (dpIndex x) (f (dpValue x) (dpValue y'))))
            where
                ys' = A.dropWhile (\y -> (dpIndex y) < (dpIndex x)) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'

-- | Apply function to the rolling window and create new Series
rollingWindow :: ∀ a b. Int -> (Array a -> b) -> Series a -> Series b
rollingWindow n agg (Series idx vs) = series idx2 $ rolling' (A.take n1 vs) agg (A.drop n1 vs)
    where
        n1 = n-1
        idx2 = A.drop n1 idx

rolling' :: ∀ a b. Array a -> (Array a -> b) -> Array a -> Array b
rolling' mu agg xs = (A.foldl f {wnd: mu, out: []} xs).out
    where
      f {wnd: ws, out: os} x = {wnd: wnd2, out: A.snoc os (agg wnd1)}
        where
            wnd1 = A.snoc ws x
            wnd2 = A.drop 1 wnd1

-- | Differentiate Series xt = xt - x(t-1)
diff :: ∀ a. Ring a => Series a -> Series a
diff (Series idx vs) = Series (A.drop 1 idx) vs2
    where
        vs2 = A.zipWith (-) (A.drop 1 vs) vs

-- | Integrate Series
integrate :: ∀ a. Ring a => Series a -> Series a
integrate (Series idx vs) = Series idx v2
    where
        v2 = snd (A.foldl f (Tuple zero []) vs)
        f (Tuple a os) x = Tuple (a+x) (A.snoc os (a+x))

-- | Group series datapoints. This will reduce series data points number by given n.
groupBy :: ∀ a b. Number    -- ^ Window size in milliseconds
        -> (Array a -> b)   -- ^ Function applied to group values
        -> Series a         -- ^ Input series
        -> Series b         -- ^ Grouped series
groupBy dt f xs = fromDataPoints $ groupBy' dt f (toDataPoints xs)

groupBy' :: ∀ a b. Number -> (Array a -> b) -> Array (DataPoint a) -> Array (DataPoint b)
groupBy' dt f xs = snd $ A.foldl g (Tuple [] []) xs
    where
        g :: Tuple (Array (DataPoint a)) (Array (DataPoint b)) -> DataPoint a -> Tuple (Array (DataPoint a)) (Array (DataPoint b))
        g (Tuple acc out) x = case A.uncons acc of
            Just {head: y, tail} -> if (dpIndex x) < (dpIndex y) + dt
                                    then Tuple (A.snoc acc x) out
                                    else Tuple [x] (A.snoc out (dataPoint (dpIndex y) (f' acc)))
            Nothing -> Tuple [x] out
        f' :: Array (DataPoint a) -> b
        f' ds = f $ map dpValue ds