Fuck browser cache! I thought I found a bug in pscr ;)

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import qualified DOM.Node.Document as ND
import qualified DOM.Node.Element as E
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N
import qualified Unsafe.Coerce as U

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

e2n :: Element -> Node
e2n = elementToNode

n2e :: Element -> Node
n2e = U.unsafeCoerce

htmlDoc :: forall eff. Eff (dom :: DOM | eff) HTMLDocument
htmlDoc = do
  w <- window
  document w

doc' :: forall eff. Eff (dom :: DOM | eff) Document
doc' = do
  d <- htmlDoc
  return $ coerceD d

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

body' :: forall eff. Eff (dom :: DOM | eff) Element
body' = do
  hb <- htmlBody
  return $ coerceE $ unsafeA hb

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

mapCol :: forall a eff. HTMLCollection ->
                        (Element -> Eff (dom :: DOM | eff) a) ->
                        Eff (dom :: DOM | eff) HTMLCollection

mapCol xs f = do
  l <- C.length xs
  mapDo l xs f
    where
      mapDo 0 xs _ = return xs
      mapDo l xs f = do
        nx <- C.item (l - 1) xs
        let x = unsafeA nx
        _ <- f x
        mapDo (l - 1) xs f

mapCards :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) HTMLCollection
mapCards = do
  d   <- doc'
  b   <- body'
  xs <- E.getElementsByClassName "card" b
  mapCol xs $ f d
    where
      f d x = do
        let xn = e2n x
        fcxn <- N.firstChild xn
        card <- N.textContent $ unsafeA fcxn
        log card
        xn1  <- N.removeChild (unsafeA fcxn) xn
        img  <- ND.createElement "img" d
        _    <- E.setAttribute "src" (cardImgURL card) img
        N.appendChild (e2n img) xn

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  mapCards
  log $ "Boom!"

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import qualified DOM.Node.Document as ND
import qualified DOM.Node.Element as E
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N
import qualified Unsafe.Coerce as U

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

e2n :: Element -> Node
e2n = elementToNode

n2e :: Element -> Node
n2e = U.unsafeCoerce

htmlDoc :: forall eff. Eff (dom :: DOM | eff) HTMLDocument
htmlDoc = do
  w <- window
  document w

doc' :: forall eff. Eff (dom :: DOM | eff) Document
doc' = do
  d <- htmlDoc
  return $ coerceD d

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

body' :: forall eff. Eff (dom :: DOM | eff) Element
body' = do
  hb <- htmlBody
  return $ coerceE $ unsafeA hb

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

mapCol :: forall a eff. HTMLCollection ->
                        (Element -> Eff (dom :: DOM | eff) a) ->
                        Eff (dom :: DOM | eff) HTMLCollection

mapCol xs f = do
  l <- C.length xs
  mapDo l xs f
    where
      mapDo 0 xs _ = return xs
      mapDo l xs f = do
        nx <- C.item (l - 1) xs
        let x = unsafeA nx
        _ <- f x
        mapDo (l - 1) xs f

mapCards :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) HTMLCollection
mapCards = do
  d   <- doc'
  b   <- body'
  xs <- E.getElementsByClassName "card" b
  mapCol xs $ f d
    where
      f d x = do
        let xn = e2n x
        fcxn <- N.firstChild xn
        card <- N.textContent $ unsafeA fcxn
        log card
        xn1  <- N.removeChild (unsafeA fcxn) xn
        img  <- ND.createElement "img" d
        _    <- E.setAttribute "src" (cardImgURL card) img
        xn1  <- N.appendChild (e2n img) xn
        return xn1

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  mapCards
  log $ "Boom!"


Refactor.

Refactor.

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, 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, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
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 Partial.Unsafe (unsafePartial)

import Network.HTTP.Affjax (AJAX, get)

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"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) 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 }

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

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

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
      astronomy = cardData.channel.astronomy
  in do
    card <- getOrCreateCard stateRef 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 cardData.channel.atmosphere.humidity <> "%")
        find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
        find ".current .wind .direction" card >>= (setText $ show cardData.channel.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 }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in 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)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (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

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

-- | 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, 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, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
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 Partial.Unsafe (unsafePartial)

import Network.HTTP.Affjax (AJAX, get)

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"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) 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 }

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

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

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
      astronomy = cardData.channel.astronomy
  in do
    card <- getOrCreateCard stateRef 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
        pure $ let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
                   cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
               in 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 cardData.channel.atmosphere.humidity <> "%")
        find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
        find ".current .wind .direction" card >>= (setText $ show cardData.channel.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 }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in 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)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (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

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

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


removing another set of parans because gary knows best

{-
Copyright 2016 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.Workspace.Deck.Gripper
  ( gripperDefsForCard
  , renderGrippers
  , module SlamData.Workspace.Deck.Gripper.Def
  ) where

import SlamData.Prelude

import Data.Array as Array
import Data.Bifoldable (bifoldMap)

import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Common (DeckHTML)
import SlamData.Workspace.Deck.Component.Query (Query(StartSliding))
import SlamData.Workspace.Deck.Component.State (DisplayCard, eqDisplayCard)
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

gripperDefsForCard
  ∷ Array DisplayCard
  → DisplayCard
  → GripperDef × GripperDef
gripperDefsForCard cards card =
  Previous previousCardAvailable × Next nextCardAvailable
  where
  previousCardAvailable =
    fromMaybe true $
      not ∘ eqDisplayCard card <$> Array.head cards

  nextCardAvailable =
    isRight card

isAvailable ∷ GripperDef → Boolean
isAvailable = case _ of
  Previous available → available
  Next available → available

gripperLabel ∷ GripperDef → String
gripperLabel = case _ of
  Previous _ → "Access previous card"
  Next _ → "Access next card"

gripperClassName ∷ GripperDef → ClassName
gripperClassName = case _ of
  Previous _ → CN.cardGripper
  Next _ → CN.cardGripperLast

renderGrippers ∷ Boolean → Boolean → GripperDef × GripperDef → Array DeckHTML
renderGrippers isActiveCard isGrabbed =
  bifoldMap render render
  where
  render ∷ GripperDef → Array DeckHTML
  render gripperDef =
    if not isAvailable gripperDef || not isActiveCard then
      []
    else
      [ HH.button
          ([ HP.classes [ gripperClassName gripperDef ]
           , HE.onMouseDown $ HE.input $ StartSliding gripperDef
           , ARIA.grabbed $ show isGrabbed
           ]
           <> (guard isActiveCard $> ARIA.label (gripperLabel gripperDef))
          )
          []
      ]

{-
Copyright 2016 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.Workspace.Deck.Gripper
  ( gripperDefsForCard
  , renderGrippers
  , module SlamData.Workspace.Deck.Gripper.Def
  ) where

import SlamData.Prelude

import Data.Array as Array
import Data.Bifoldable (bifoldMap)

import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Common (DeckHTML)
import SlamData.Workspace.Deck.Component.Query (Query(StartSliding))
import SlamData.Workspace.Deck.Component.State (DisplayCard, eqDisplayCard)
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

gripperDefsForCard
  ∷ Array DisplayCard
  → DisplayCard
  → GripperDef × GripperDef
gripperDefsForCard cards card =
  Previous previousCardAvailable × Next nextCardAvailable
  where
  previousCardAvailable =
    fromMaybe true $
      not ∘ eqDisplayCard card <$> Array.head cards

  nextCardAvailable =
    isRight card

isAvailable ∷ GripperDef → Boolean
isAvailable = case _ of
  Previous available → available
  Next available → available

gripperLabel ∷ GripperDef → String
gripperLabel = case _ of
  Previous _ → "Access previous card"
  Next _ → "Access next card"

gripperClassName ∷ GripperDef → ClassName
gripperClassName = case _ of
  Previous _ → CN.cardGripper
  Next _ → CN.cardGripperLast

renderGrippers ∷ Boolean → Boolean → GripperDef × GripperDef → Array DeckHTML
renderGrippers isActiveCard isGrabbed =
  bifoldMap render render
  where
  render ∷ GripperDef → Array DeckHTML
  render gripperDef =
    if not (isAvailable gripperDef) || not isActiveCard then
      []
    else
      [ HH.button
          ([ HP.classes [ gripperClassName gripperDef ]
           , HE.onMouseDown $ HE.input $ StartSliding gripperDef
           , ARIA.grabbed $ show isGrabbed
           ]
           <> (guard isActiveCard $> ARIA.label (gripperLabel gripperDef))
          )
          []
      ]


[CSE-68] Update `api` view to latest `psc`/`pux`

module Explorer.View.Dashboard.Api (apiView) where

import Prelude
import Data.Lens ((^.))
import Data.Map (Map, fromFoldable, lookup, toAscUnfoldable) as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (dbAboutBlockchain, dbAboutBlockchainDescription, dbCurl
    , dbGetAddress, dbGetApiKey, dbMoreExamples, dbJQuery, dbNode, dbResponse
    , cApi, common, dashboard) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (DashboardAPICode(..), State)
import Explorer.View.Dashboard.Lenses (dashboardSelectedApiCode)
import Explorer.View.Dashboard.Shared (headerView)
import Explorer.View.Dashboard.Types (HeaderLink(..), HeaderOptions(..))

import Text.Smolder.HTML (div, h3, text, p, code)
import Text.Smolder.HTML.Attributes (className, href)
import Text.Smolder.Markup (text, (#!), (!))

import Pux.DOM.HTML (Html) as P
import Pux.DOM.Events (onClick) as P
import Pux.Renderer.React (dangerouslySetInnerHTML) as P

type ApiTabLabel = String

type ApiCode =
    { getAddress :: String
    , response :: String
    }

emptyApiCode :: ApiCode
emptyApiCode = { getAddress: "", response: ""}

apiCodes :: M.Map DashboardAPICode ApiCode
apiCodes =
    M.fromFoldable (
      [ Tuple Curl { getAddress: "Curl getAddress", response: "{\n\t\"hash\": }"}
      , Tuple Node { getAddress: "Node getAddress", response: "Node response ..."}
      , Tuple JQuery { getAddress: "jQuery getAddress", response: "jQuery response ..."}
      ]
    )

apiView :: State -> P.Html Action
apiView state =
    div ! className "explorer-dashboard__wrapper" $ do
        div ! className "explorer-dashboard__container" $ do
            headerView state $ headerOptions lang'
            div ! className "api-content" $ do
                div ! className "api-content__container api-code" $ do
                    div ! className "api-code__tabs" $ do
                        map (apiCodeTabView state) <<< M.toAscUnfoldable $ apiTabs lang'
                        apiCodeSnippetView (translate (I18nL.dashboard <<< I18nL.dbGetAddress) lang') addressSnippet
                        apiCodeSnippetView (translate (I18nL.dashboard <<< I18nL.dbResponse) lang') responseSnippet
                div ! className "api-content__container api-about" $ do
                    h3  ! className "api-about__headline"
                        $ text (translate (I18nL.dashboard <<< I18nL.dbAboutBlockchain) lang')
                    p   ! className "api-about__description"
                        ! P.dangerouslySetInnerHTML (translate (I18nL.dashboard <<< I18nL.dbAboutBlockchainDescription) lang')
                div ! className "api-about__button"
                    $ text (translate (I18nL.dashboard <<< I18nL.dbGetApiKey) lang')
    where
      apiCode :: ApiCode
      apiCode = fromMaybe emptyApiCode $ M.lookup (state ^. dashboardSelectedApiCode) apiCodes
      lang' = state ^. lang
      addressSnippet = _.getAddress $ apiCode
      responseSnippet = _.response $ apiCode
      headerOptions lang = HeaderOptions
          { headline: translate (I18nL.common <<< I18nL.cApi) lang
          , link: Just $ HeaderLink { label: translate (I18nL.dashboard <<< I18nL.dbMoreExamples) lang', action: NoOp }
          }

apiTabs :: Language -> M.Map DashboardAPICode ApiTabLabel
apiTabs lang =
    M.fromFoldable(
        [ Tuple Curl $ translate (I18nL.dashboard <<< I18nL.dbCurl) lang
        , Tuple Node $ translate (I18nL.dashboard <<< I18nL.dbNode) lang
        , Tuple JQuery $ translate (I18nL.dashboard <<< I18nL.dbJQuery) lang
        ])

apiCodeTabView :: State -> Tuple DashboardAPICode ApiTabLabel -> P.Html Action
apiCodeTabView state (Tuple code label) =
    div ! className $ "api-code__tab " <> selectedClazz
        #! onClick <<< const $ DashboardShowAPICode code
        $ text label
    where
      selectedClazz = if state ^. dashboardSelectedApiCode == code then "selected" else ""

apiCodeSnippetView :: String -> String -> P.Html Action
apiCodeSnippetView headline snippet =
    div ! className "api-snippet" $ do
        h3  ! className "api-snippet__headline"
            $ text headline
        code  ! className "api-snippet__code"
              $ text snippet

module Explorer.View.Dashboard.Api (apiView) where

import Prelude
import Data.Lens ((^.))
import Data.Map (Map, fromFoldable, lookup, toAscUnfoldable) as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (dbAboutBlockchain, dbAboutBlockchainDescription, dbCurl
    , dbGetAddress, dbGetApiKey, dbMoreExamples, dbJQuery, dbNode, dbResponse
    , cApi, common, dashboard) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (DashboardAPICode(..), State)
import Explorer.View.Dashboard.Lenses (dashboardSelectedApiCode)
import Explorer.View.Dashboard.Shared (headerView)
import Explorer.View.Dashboard.Types (HeaderLink(..), HeaderOptions(..))
import Pux.Html (Html, div, h3, text, p, code) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML) as P
import Pux.Html.Events (onClick) as P

type ApiTabLabel = String

type ApiCode =
    { getAddress :: String
    , response :: String
    }

emptyApiCode :: ApiCode
emptyApiCode = { getAddress: "", response: ""}

apiCodes :: M.Map DashboardAPICode ApiCode
apiCodes =
  M.fromFoldable([
    Tuple Curl { getAddress: "Curl getAddress", response: "{\n\t\"hash\": }"}
    , Tuple Node { getAddress: "Node getAddress", response: "Node response ..."}
    , Tuple JQuery { getAddress: "jQuery getAddress", response: "jQuery response ..."}
    ])

apiView :: State -> P.Html Action
apiView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ headerView state $ headerOptions lang'
          , P.div
            [ P.className "api-content" ]
            [ P.div
                [ P.className "api-content__container api-code"]
                [ P.div
                  [ P.className "api-code__tabs" ]
                  <<< map (apiCodeTabView state) <<< M.toAscUnfoldable $ apiTabs lang'
                , apiCodeSnippetView (translate (I18nL.dashboard <<< I18nL.dbGetAddress) lang') addressSnippet
                , apiCodeSnippetView (translate (I18nL.dashboard <<< I18nL.dbResponse) lang') responseSnippet
                ]
            , P.div
                [ P.className "api-content__container api-about"]
                [ P.h3
                    [ P.className "api-about__headline" ]
                    [ P.text $ translate (I18nL.dashboard <<< I18nL.dbAboutBlockchain) lang' ]
                , P.p
                    [ P.className "api-about__description"
                    , P.dangerouslySetInnerHTML $ translate (I18nL.dashboard <<< I18nL.dbAboutBlockchainDescription) lang' ]
                    []
                , P.div
                  [ P.className "api-about__button" ]
                  [ P.text $ translate (I18nL.dashboard <<< I18nL.dbGetApiKey) lang' ]
                ]
            ]
          ]
        ]
    where
      apiCode :: ApiCode
      apiCode = fromMaybe emptyApiCode $ M.lookup (state ^. dashboardSelectedApiCode) apiCodes
      lang' = state ^. lang
      addressSnippet = _.getAddress $ apiCode
      responseSnippet = _.response $ apiCode
      headerOptions lang = HeaderOptions
          { headline: translate (I18nL.common <<< I18nL.cApi) lang
          , link: Just $ HeaderLink { label: translate (I18nL.dashboard <<< I18nL.dbMoreExamples) lang', action: NoOp }
          }

apiTabs :: Language -> M.Map DashboardAPICode ApiTabLabel
apiTabs lang =
    M.fromFoldable(
        [ Tuple Curl $ translate (I18nL.dashboard <<< I18nL.dbCurl) lang
        , Tuple Node $ translate (I18nL.dashboard <<< I18nL.dbNode) lang
        , Tuple JQuery $ translate (I18nL.dashboard <<< I18nL.dbJQuery) lang
        ])

apiCodeTabView :: State -> Tuple DashboardAPICode ApiTabLabel -> P.Html Action
apiCodeTabView state (Tuple code label) =
    P.div
      [ P.className $ "api-code__tab " <> selectedClazz
      , P.onClick <<< const $ DashboardShowAPICode code ]
      [ P.text label ]
    where
      selectedClazz = if state ^. dashboardSelectedApiCode == code then "selected" else ""

apiCodeSnippetView :: String -> String -> P.Html Action
apiCodeSnippetView headline snippet =
    P.div
        [ P.className "api-snippet" ]
        [ P.h3
            [ P.className "api-snippet__headline" ]
            [ P.text headline ]
        , P.code
            [ P.className "api-snippet__code" ]
            [ P.text snippet ]

        ]


case newlines

case newlines

{-
Copyright 2016 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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import DOM.Event.Event as DEE

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


Removed test line, added function to prevent movement in solid tiles (does not work, so code in comments)

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

type GameState = { level :: Level, player :: Creature }

initialState :: GameState
initialState = { level: stringToLevel testLevel, player: pl }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt state = do
    drawGame console state
    return state

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console state = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    drawString console "Hello worlllddd" "0000FF" 2 8
    drawCreature state.player
    return state
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c | c.ctype == Player  = drawChar console "@" "FF0000" c.pos.x c.pos.y
        drawCreature c | c.ctype == Guard   = drawChar console "G" "0000FF" c.pos.x c.pos.y
        drawCreature c | c.ctype == Archer  = drawChar console "A" "00FF00" c.pos.x c.pos.y
        drawCreature c | c.ctype == Peasant = drawChar console "P" "AAAAFF" c.pos.x c.pos.y
        drawCreature _                      = drawChar console "?" "FFFFFF" 0 0

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)    = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground) = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)   = drawChar console "#" "331A00" p.x p.y
        drawTile p _             = drawChar console "?" "FFFFFF" p.x p.y

updateWorld :: GameState -> GameState
updateWorld state = state

--isValidMove :: Level -> Point -> Boolean
--isValidMove = isTileSolid <<< fromMaybe Air <<< getTile

movePlayer :: Tuple Number Number -> GameState -> GameState
--movePlayer (Tuple dx dy) state | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = state
--movePlayer (Tuple dx dy) state | otherwise = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
movePlayer (Tuple dx dy) state = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console state key = case M.lookup key movementkeys of
    Just delta -> drawGame console $ movePlayer delta state
    Nothing    -> return state

onKeyPress console state key = trace $ show key >> return state

main = J.ready $ withConsole 80 25 initialState {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

type GameState = { level :: Level, player :: Creature }

initialState :: GameState
initialState = { level: stringToLevel testLevel, player: pl }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt state = do
    drawGame console state
    return state

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console state = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    drawString console "Hello worlllddd" "0000FF" 2 8
    drawString console "This is a test line" "CCCC00" 5 21
    drawCreature state.player
    return state
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c | c.ctype == Player  = drawChar console "@" "FF0000" c.pos.x c.pos.y
        drawCreature c | c.ctype == Guard   = drawChar console "G" "0000FF" c.pos.x c.pos.y
        drawCreature c | c.ctype == Archer  = drawChar console "A" "00FF00" c.pos.x c.pos.y
        drawCreature c | c.ctype == Peasant = drawChar console "P" "AAAAFF" c.pos.x c.pos.y
        drawCreature _                      = drawChar console "?" "FFFFFF" 0 0

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)    = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground) = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)   = drawChar console "#" "331A00" p.x p.y
        drawTile p _             = drawChar console "?" "FFFFFF" p.x p.y

updateWorld :: GameState -> GameState
updateWorld state = state

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) state = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console state key = case M.lookup key movementkeys of
    Just delta -> drawGame console $ movePlayer delta state
    Nothing    -> return state

onKeyPress console state key = trace $ show key >> return state

main = J.ready $ withConsole 80 25 initialState {onKeyPress: onKeyPress, onUpdate: onUpdate}


Fix bug in parsing of --purs= command (#26)

module Main where

import Prelude
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throw, throwException)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter

foreign import version :: String

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , purs :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 7 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf (Str.Pattern s) str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: NOW
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , purs
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (_ <> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "compile" $ Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafePartial (Array.unsafeIndex Child.inherit 1), Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (_ <> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix (Str.Pattern ".cmd") cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> toDateTime <$> now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --purs=PURS            Name of purs executable (defaults to 'purs')

  CODES                  Comma-separated list of purs error codes
  PSC_OPTIONS            Any extra options are passed to 'purs compile'
"""

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))

module Main where

import Prelude
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throw, throwException)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter

foreign import version :: String

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , purs :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 6 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf (Str.Pattern s) str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: NOW
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , purs
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (_ <> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "compile" $ Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafePartial (Array.unsafeIndex Child.inherit 1), Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (_ <> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix (Str.Pattern ".cmd") cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> toDateTime <$> now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --purs=PURS            Name of purs executable (defaults to 'purs')

  CODES                  Comma-separated list of purs error codes
  PSC_OPTIONS            Any extra options are passed to 'purs compile'
"""

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))


Start evaluation on enter key press

Start evaluation on enter key press

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Data.Array ((..), length, deleteAt, (!!), drop)
import Data.Tuple
import Data.Traversable (zipWithA)
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

foreign import isEnterKey
  """
  function isEnterKey(event) {
    return event.which == 13;
  }
  """ :: J.JQueryEvent -> Boolean

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => [a] -> (a -> Number -> m b) -> m [b]
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: [Expr] -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. [a] -> Number -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Number -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = deleteAt i 1 es.history }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left  _ -> return unit
      Right _ -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    Left msg   -> liftEff $ do
      info <- J.create "

" >>= J.setText msg
      J.select "#info"
        >>= J.clear
        >>= J.removeClass "hidden"
        >>= J.append info
      return unit
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Data.Array ((..), length, deleteAt, (!!), drop)
import Data.Tuple
import Data.Traversable (zipWithA)
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => [a] -> (a -> Number -> m b) -> m [b]
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: [Expr] -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. [a] -> Number -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Number -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = deleteAt i 1 es.history }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left  _ -> return unit
      Right _ -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    Left msg   -> liftEff $ do
      info <- J.create "

" >>= J.setText msg
      J.select "#info"
        >>= J.clear
        >>= J.removeClass "hidden"
        >>= J.append info
      return unit
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq


Remove dead code

Remove dead code

Original commit d7ae3768153037c88a5d6db81c071045fff0c7d9

module Main
    ( renderFromJsonArrayMap
    , renderFromJsonSchemaArrayMap
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    , urlsFromJsonGrammar
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Elm as Elm
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaListToIR)
import JsonSchema as JsonSchema
import UrlGrammar (GrammarMap(..), generate)
import TypeScript as TypeScript
import Utils (foldErrorArray, foldErrorStrMap, forStrMap_, mapM, mapStrMapM)

type Error = String
type SourceCode = String

-- A type representing the input to Pipelines
-- This makes pipelines easier to call from JavaScript
type Input a =
    { input :: a
    , renderer :: Doc.Renderer
    }

type Pipeline a = Input a -> Either Error SourceCode

renderers :: Array Doc.Renderer
renderers =
    [ TypeScript.renderer
    , Golang.renderer
    , CSharp.renderer
    , Elm.renderer
    , JsonSchema.renderer
    ]

makeTypeFromJson :: Either String String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular $ either id id name
        typeList <- mapM (makeTypeFromJson $ Right typeName) $ L.fromFoldable arr
        unifiedType <- unifyMultipleTypes typeList
        pure $ IRArray unifiedType)
    (\obj -> do
        let l1 = SM.toUnfoldable obj :: Array _
        l2 <- mapM toProperty l1
        addClass $ makeClass name $ Map.fromFoldable l2)
    json
    where
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson (Right name) json

makeTypeAndUnify :: StrMap (Array Json) -> IRGraph
makeTypeAndUnify jsonArrayMap = execIR do
    forStrMap_ jsonArrayMap \name jsonArray -> do
        topLevelTypes <- mapM (makeTypeFromJson $ Left name) $ L.fromFoldable jsonArray
        topLevel <- unifyMultipleTypes topLevelTypes
        addTopLevel name topLevel
    replaceSimilarClasses
    makeMaps

makeTypeFromSchemaArrayMap :: StrMap (Array JSONSchema) -> Either Error IRGraph
makeTypeFromSchemaArrayMap schemaArrayMap = eitherify $ runIR do
    topLevelOrErrorMap <- mapStrMapM (\n -> jsonSchemaListToIR $ Left n) schemaArrayMap
    case foldErrorStrMap topLevelOrErrorMap of
        Left err -> pure $ Just err
        Right topLevelMap -> do
            for_ (SM.toUnfoldable topLevelMap :: Array _) \(Tuple name topLevel) -> do
                addTopLevel name topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJsonArrayMap :: Pipeline (StrMap (Array Json))
renderFromJsonArrayMap { renderer, input: jsonArrayMap } =
    jsonArrayMap
    # makeTypeAndUnify
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

mapStrMapArrayWithError :: forall a b c. (a -> Either b c) -> StrMap (Array a) -> Either b (StrMap (Array c))
mapStrMapArrayWithError f sm =
    let mapWithErrors = SM.mapWithKey (\_ arr -> foldErrorArray $ map f arr) sm
    in
        foldErrorStrMap mapWithErrors

renderFromJsonSchemaArrayMap :: Pipeline (StrMap (Array Json))
renderFromJsonSchemaArrayMap { renderer, input: jsonArrayMap } = do
    schemaArrayMap <- mapStrMapArrayWithError J.decodeJson jsonArrayMap
    graph <- makeTypeFromSchemaArrayMap schemaArrayMap
    graph
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline (StrMap (Array Json)))
pipelines Development = [renderFromJsonArrayMap]
pipelines Production = [renderFromJsonArrayMap]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes input = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline input

renderFromJsonStringPossiblyAsSchemaInDevelopment :: String -> Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment  topLevelName { renderer, input: jsonString } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: SM.singleton topLevelName [obj] }

urlsFromJsonGrammar :: Json -> Either String (StrMap (Array String))
urlsFromJsonGrammar json =
    case J.decodeJson json of
    Left err -> Left err
    Right (GrammarMap grammarMap) -> Right $ SM.mapWithKey (const generate) grammarMap

module Main
    ( renderFromJsonArrayMap
    , renderFromJsonSchemaArrayMap
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    , urlsFromJsonGrammar
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Elm as Elm
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaListToIR)
import JsonSchema as JsonSchema
import UrlGrammar (GrammarMap(..), generate)
import TypeScript as TypeScript
import Utils (foldErrorArray, foldErrorStrMap, forStrMap_, mapM, mapStrMapM)

type Error = String
type SourceCode = String

-- A type representing the input to Pipelines
-- This makes pipelines easier to call from JavaScript
type Input a =
    { input :: a
    , renderer :: Doc.Renderer
    }

type Pipeline a = Input a -> Either Error SourceCode

renderers :: Array Doc.Renderer
renderers =
    [ TypeScript.renderer
    , Golang.renderer
    , CSharp.renderer
    , Elm.renderer
    , JsonSchema.renderer
    ]

makeTypeFromJson :: Either String String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular $ either id id name
        typeList <- mapM (makeTypeFromJson $ Right typeName) $ L.fromFoldable arr
        unifiedType <- unifyMultipleTypes typeList
        pure $ IRArray unifiedType)
    (\obj -> do
        let l1 = SM.toUnfoldable obj :: Array _
        l2 <- mapM toProperty l1
        addClass $ makeClass name $ Map.fromFoldable l2)
    json
    where
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson (Right name) json

makeTypeAndUnify :: StrMap (Array Json) -> IRGraph
makeTypeAndUnify jsonArrayMap = execIR do
    forStrMap_ jsonArrayMap \name jsonArray -> do
        topLevelTypes <- mapM (makeTypeFromJson $ Left name) $ L.fromFoldable jsonArray
        topLevel <- unifyMultipleTypes topLevelTypes
        addTopLevel name topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchemaArrayMap :: StrMap (Array JSONSchema) -> Either Error IRGraph
makeTypeFromSchemaArrayMap schemaArrayMap = eitherify $ runIR do
    topLevelOrErrorMap <- mapStrMapM (\n -> jsonSchemaListToIR $ Left n) schemaArrayMap
    case foldErrorStrMap topLevelOrErrorMap of
        Left err -> pure $ Just err
        Right topLevelMap -> do
            for_ (SM.toUnfoldable topLevelMap :: Array _) \(Tuple name topLevel) -> do
                addTopLevel name topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJsonArrayMap :: Pipeline (StrMap (Array Json))
renderFromJsonArrayMap { renderer, input: jsonArrayMap } =
    jsonArrayMap
    # makeTypeAndUnify
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

mapStrMapArrayWithError :: forall a b c. (a -> Either b c) -> StrMap (Array a) -> Either b (StrMap (Array c))
mapStrMapArrayWithError f sm =
    let mapWithErrors = SM.mapWithKey (\_ arr -> foldErrorArray $ map f arr) sm
    in
        foldErrorStrMap mapWithErrors

renderFromJsonSchemaArrayMap :: Pipeline (StrMap (Array Json))
renderFromJsonSchemaArrayMap { renderer, input: jsonArrayMap } = do
    schemaArrayMap <- mapStrMapArrayWithError J.decodeJson jsonArrayMap
    graph <- makeTypeFromSchemaArrayMap schemaArrayMap
    graph
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline (StrMap (Array Json)))
pipelines Development = [renderFromJsonArrayMap]
pipelines Production = [renderFromJsonArrayMap]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes input = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline input

renderFromJsonStringPossiblyAsSchemaInDevelopment :: String -> Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment  topLevelName { renderer, input: jsonString } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: SM.singleton topLevelName [obj] }

urlsFromJsonGrammar :: Json -> Either String (StrMap (Array String))
urlsFromJsonGrammar json =
    case J.decodeJson json of
    Left err -> Left err
    Right (GrammarMap grammarMap) -> Right $ SM.mapWithKey (const generate) grammarMap