get rid of needless parameters and excess rowlist traversal

module Main where

import Prelude

import Config as C
import Control.Monad.Except (ExceptT, except, runExceptT, throwError)
import Data.Array (filter, sortBy)
import Data.Bifunctor (lmap)
import Data.Either (Either(Left, Right))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.Class (liftAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Jajanmen as J
import Makkori as M
import Node.Buffer (Buffer, create, writeString)
import Node.ChildProcess (Exit(..), defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (mkdir, readTextFile, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (platform)
import Prim.Row as Row
import Record as Record
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, FilePath, newDB)
import SQLite3 as SQL
import Shoronpo (formatSymbol, intercalateRecordLabels, intercalateRowLabels, intercalateRowValues)
import Simple.JSON (class ReadForeign, class WriteForeign, read, writeJSON)
import Sunde as Sunde
import Tortellini (parsellIni)
import Type.Prelude (class RowToList, Proxy(..), RLProxy(RLProxy))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData, GetIconsRequest, OpenRequest, Operation, Path(Path), RemoveRequest, WatchedData)

data Error
  = ServerError String
  | UserError String

prepareResult :: forall a. WriteForeign a => Either Error a -> {status :: Int, response :: String}
prepareResult (Left (UserError error)) = {status: 400, response: writeJSON {error}}
prepareResult (Left (ServerError error)) = {status: 500, response: writeJSON {error}}
prepareResult (Right result) = {status: 200, response: writeJSON result}

readdir' :: String -> Aff (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: Int -> String -> Effect Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  , exe :: String
  }

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF :: GetFiles (ExceptT Error Aff) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA :: GetWatched (ExceptT Error Aff) where
  getWatchedData {db} = do
    let
      template = SProxy :: SProxy "select {columns} from watched"
      query = formatSymbol template
        { columns: intercalateRecordLabels (Proxy :: Proxy WatchedData) (SProxy :: SProxy ", ") }
    results <- liftAff $ J.queryDB db query {}
    case read results of
      Right xs -> do
        pure xs
      Left e -> do
        throwError <<< ServerError $ "getWatchedData:" <> show e

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Operation

instance giA :: GetIcons (ExceptT Error Aff) where
  getIconsData {db} _ = do
    result <- liftAff $ Sunde.spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ case result.exit of
      Normally 0 -> {success: true}
      _ -> {success: false}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA :: UpdateWatched (ExceptT Error Aff) where
  updateWatched config@{db} ur = do
    let params = {"$path": unwrap ur.path}
    _ <- liftAff $ if ur.watched
      then do
        let
          fields =
            { path: SProxy :: SProxy "$path"
            , created: SProxy :: SProxy "datetime()"
            }
          template = SProxy :: SProxy "insert or replace into watched ({fields}) values ({values})"
          query = formatSymbol template
            { fields: intercalateRowLabels fields (SProxy :: SProxy ", ")
            , values: intercalateRowValues fields (SProxy :: SProxy ", ")
            }
        void $ J.queryDB db query params
      else do
        let queryString = SProxy :: SProxy "delete from watched where path = $path"
        void $ J.queryDB db queryString params
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Operation)

instance ofA :: OpenFile (ExceptT Error Aff) where
  openFile {dir, exe} or = do
    let
      simpleOpen = case exe, platform of
        exe', _ | exe' /= "" -> Just exe'
        _, Just Linux -> Just "xdg-open"
        _, Just Darwin -> Just "open"
        _, _ -> Nothing
    _ <- liftAff $ case simpleOpen of
          Just command -> liftEffect $ void $ spawn command (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEffect $ void $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ {success: true}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Operation)

instance rfA :: RemoveFile (ExceptT Error Aff) where
  removeFile {dir} rr = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ {success: true}

ensureDB :: FilePath -> Aff DBConnection
ensureDB path = do
  db <- newDB path
  _ <- SQL.queryDB db "create table if not exists watched (path text primary key unique, created datetime)" []
  pure db

registerRoutes :: forall routes handlers routesL
   . RowToList routes routesL
  => RoutesHandlers routesL routes handlers
  => Record routes
  -> Record handlers
  -> M.App
  -> Effect Unit
registerRoutes = registerRoutesImpl (RLProxy :: RLProxy routesL)

class RoutesHandlers
  (routesL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  | routesL -> routes handlers
  where
    registerRoutesImpl :: forall proxy
       . proxy routesL
      -> Record routes
      -> Record handlers
      -> M.App
      -> Effect Unit

instance routesHandlersNil :: RoutesHandlers Nil routes handlers where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers tail routes handlers
  , IsSymbol name
  , Row.Cons name handler handlers' handlers
  , Row.Cons name route routes' routes
  , RegisterHandler route handler
  ) => RoutesHandlers (Cons name route tail) routes handlers where
  registerRoutesImpl _ routes handlers app = do
    registerHandlerImpl (Record.get nameP routes) (Record.get nameP handlers) app
    registerRoutesImpl (RLProxy :: RLProxy tail) routes handlers app
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler
  | route -> handler
  where
    registerHandlerImpl :: route -> handler -> M.App -> Effect Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.post (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' req res = do
        body <- M.getBody req
        launchAff_ do
          {status, response} <- prepareResult <$> runExceptT do
            r :: req <- except <<< lmap (UserError <<< show) $ read body
            handler r
          liftEffect do
            M.setStatus status res
            M.sendResponse response res

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.get (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' _ res = launchAff_ do
        {status, response} <- prepareResult <$> runExceptT handler
        liftEffect do
          M.setStatus status res
          M.sendResponse response res

main :: Effect Unit
main = launchAff_ do
  dir' <- parsellIni <$> readTextFile UTF8 "./config.ini"
  case dir' of
    Left e -> log $ "We broke: " <> show e
    Right ({vidtracker} :: C.Config) -> do
      db <- ensureDB $ concat [vidtracker.dir, "filetracker"]
      let config = Record.merge vidtracker {db}
      _ <- liftEffect do
        app <- M.makeApp

        middlewares <- sequence
          [ M.makeJSONMiddleware {}
          , M.makeStaticMiddleware (M.Path "dist") {}
          ]
        traverse_ (flip (M.use (M.Path "/")) app) middlewares

        registerRoutes
          apiRoutes
          { files: getFiles config
          , watched: getWatchedData config
          , getIcons: getIconsData config
          , update: updateWatched config
          , open: openFile config
          , remove: removeFile config
          }
          app

        _ <- M.listen (M.Port 3000) (log "Started server") app
        pure unit
      pure unit

module Main where

import Prelude

import Config as C
import Control.Monad.Except (ExceptT, except, runExceptT, throwError)
import Data.Array (filter, sortBy)
import Data.Bifunctor (lmap)
import Data.Either (Either(Left, Right))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.Class (liftAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Jajanmen as J
import Makkori as M
import Node.Buffer (Buffer, create, writeString)
import Node.ChildProcess (Exit(..), defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (mkdir, readTextFile, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (platform)
import Prim.Row as Row
import Record as Record
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, FilePath, newDB)
import SQLite3 as SQL
import Shoronpo (formatSymbol, intercalateRecordLabels, intercalateRowLabels, intercalateRowValues)
import Simple.JSON (class ReadForeign, class WriteForeign, read, writeJSON)
import Sunde as Sunde
import Tortellini (parsellIni)
import Type.Prelude (class RowToList, Proxy(..), RLProxy(RLProxy))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData, GetIconsRequest, OpenRequest, Operation, Path(Path), RemoveRequest, WatchedData)

data Error
  = ServerError String
  | UserError String

prepareResult :: forall a. WriteForeign a => Either Error a -> {status :: Int, response :: String}
prepareResult (Left (UserError error)) = {status: 400, response: writeJSON {error}}
prepareResult (Left (ServerError error)) = {status: 500, response: writeJSON {error}}
prepareResult (Right result) = {status: 200, response: writeJSON result}

readdir' :: String -> Aff (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: Int -> String -> Effect Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  , exe :: String
  }

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF :: GetFiles (ExceptT Error Aff) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA :: GetWatched (ExceptT Error Aff) where
  getWatchedData {db} = do
    let
      template = SProxy :: SProxy "select {columns} from watched"
      query = formatSymbol template
        { columns: intercalateRecordLabels (Proxy :: Proxy WatchedData) (SProxy :: SProxy ", ") }
    results <- liftAff $ J.queryDB db query {}
    case read results of
      Right xs -> do
        pure xs
      Left e -> do
        throwError <<< ServerError $ "getWatchedData:" <> show e

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Operation

instance giA :: GetIcons (ExceptT Error Aff) where
  getIconsData {db} _ = do
    result <- liftAff $ Sunde.spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ case result.exit of
      Normally 0 -> {success: true}
      _ -> {success: false}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA :: UpdateWatched (ExceptT Error Aff) where
  updateWatched config@{db} ur = do
    let params = {"$path": unwrap ur.path}
    _ <- liftAff $ if ur.watched
      then do
        let
          fields =
            { path: SProxy :: SProxy "$path"
            , created: SProxy :: SProxy "datetime()"
            }
          template = SProxy :: SProxy "insert or replace into watched ({fields}) values ({values})"
          query = formatSymbol template
            { fields: intercalateRowLabels fields (SProxy :: SProxy ", ")
            , values: intercalateRowValues fields (SProxy :: SProxy ", ")
            }
        void $ J.queryDB db query params
      else do
        let queryString = SProxy :: SProxy "delete from watched where path = $path"
        void $ J.queryDB db queryString params
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Operation)

instance ofA :: OpenFile (ExceptT Error Aff) where
  openFile {dir, exe} or = do
    let
      simpleOpen = case exe, platform of
        exe', _ | exe' /= "" -> Just exe'
        _, Just Linux -> Just "xdg-open"
        _, Just Darwin -> Just "open"
        _, _ -> Nothing
    _ <- liftAff $ case simpleOpen of
          Just command -> liftEffect $ void $ spawn command (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEffect $ void $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ {success: true}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Operation)

instance rfA :: RemoveFile (ExceptT Error Aff) where
  removeFile {dir} rr = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ {success: true}

ensureDB :: FilePath -> Aff DBConnection
ensureDB path = do
  db <- newDB path
  _ <- SQL.queryDB db "create table if not exists watched (path text primary key unique, created datetime)" []
  pure db

registerRoutes :: forall routes handlers routesL handlersL app m
   . RowToList routes routesL
  => RowToList handlers handlersL
  => Monad m
  => RoutesHandlers routesL handlersL routes handlers app m
  => Record routes
  -> Record handlers
  -> app
  -> m Unit
registerRoutes routes handlers app =
  registerRoutesImpl
    (RLProxy :: RLProxy routesL)
    (RLProxy :: RLProxy handlersL)
    routes
    handlers
    app

class RoutesHandlers
  (routesL :: RowList)
  (handlersL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  app
  m
  where
    registerRoutesImpl :: forall proxy
       . Monad m
      => proxy routesL
      -> proxy handlersL
      -> Record routes
      -> Record handlers
      -> app
      -> m Unit

instance routesHandlersNil :: RoutesHandlers Nil Nil trash1 trash2 app m where
  registerRoutesImpl _ _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers rTail hTail routes handlers app m
  , IsSymbol name
  , Row.Cons name handler trash1 handlers
  , Row.Cons name route trash2 routes
  , RegisterHandler route handler app m
  ) => RoutesHandlers (Cons name route rTail) (Cons name handler hTail) routes handlers app m where
  registerRoutesImpl _ _ routes handlers app = do
    registerHandlerImpl (Record.get nameP routes) (Record.get nameP handlers) app
    registerRoutesImpl (RLProxy :: RLProxy rTail) (RLProxy :: RLProxy hTail) routes handlers app
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler app m
  | route -> handler app m
  where
    registerHandlerImpl :: route -> handler -> app -> m Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> ExceptT Error Aff res)
         M.App
         Aff where
  registerHandlerImpl route handler app =
    liftEffect $ M.post (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' req res = do
        body <- M.getBody req
        launchAff_ do
          {status, response} <- prepareResult <$> runExceptT do
            r :: req <- except <<< lmap (UserError <<< show) $ read body
            handler r
          liftEffect do
            M.setStatus status res
            M.sendResponse response res

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (ExceptT Error Aff res)
         M.App
         Aff where
  registerHandlerImpl route handler app =
    liftEffect $ M.get (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' _ res = launchAff_ do
        {status, response} <- prepareResult <$> runExceptT handler
        liftEffect do
          M.setStatus status res
          M.sendResponse response res

main :: Effect Unit
main = launchAff_ do
  dir' <- parsellIni <$> readTextFile UTF8 "./config.ini"
  case dir' of
    Left e -> log $ "We broke: " <> show e
    Right ({vidtracker} :: C.Config) -> do
      db <- ensureDB $ concat [vidtracker.dir, "filetracker"]
      let config = Record.merge vidtracker {db}
      app <- liftEffect M.makeApp

      middlewares <- liftEffect $ sequence
        [ M.makeJSONMiddleware {}
        , M.makeStaticMiddleware (M.Path "dist") {}
        ]
      liftEffect $ traverse_ (flip (M.use (M.Path "/")) app) middlewares

      registerRoutes
        apiRoutes
        { files: getFiles config
        , watched: getWatchedData config
        , getIcons: getIconsData config
        , update: updateWatched config
        , open: openFile config
        , remove: removeFile config
        }
        app

      _ <- liftEffect $ M.listen (M.Port 3000) (log "Started server") app
      pure unit


show args

show args

module Main where

import Prelude (Unit, ($), (<>), bind, show)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (drop) as Array
import Node.Process (PROCESS, argv) as Process

main :: forall e. Eff (console :: CONSOLE, process :: Process.PROCESS | e) Unit
main = do
  argv <- Process.argv
  let args = Array.drop 2 $ argv
  log $ "args: " <> show args

module Main where

import Prelude (Unit, ($), (<>), bind, show)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Node.Process (PROCESS, argv) as Process

main :: forall e. Eff (console :: CONSOLE, process :: Process.PROCESS | e) Unit
main = do
  argv <- Process.argv
  log $ "argv: " <> show argv


HSTS bites again

HSTS bites again

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 40.371975 (-83.060578)
  roadmap <- gMap mapE (MapOptions { zoom: 10, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://mv-ws1-b.elrod.me:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker roadmap)
  --sendWS socket example

  where
    handleEvent e mvcA polyline marker roadmap = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker roadmap result.coordinates
          updateLookangle result.coordinates result.altitude
          updateTimestamp result.time
          updateTemperature result.temperature
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker roadmap) coordinates

updateTemperature ::
  forall eff.
  Celsius
  -> Eff (dom :: DOM | eff) Unit
updateTemperature temp = do
  doc <- document globalWindow
  Just tempField <- getElementById "temperature" doc
  setInnerHTML (show temp) tempField

updateTimestamp ::
  forall eff.
  String
  -> Eff (dom :: DOM, now :: MomentJS.Now | eff) Unit
updateTimestamp time = do
  doc <- document globalWindow
  --nowMoment <- now
  --let last = createMoment (momentConstructor time)
  Just lastupdate <- getElementById "lastupdate" doc
  --let str = liftMoment2 momentFrom nowMoment <$> last
  --let humanReadableTime = fromMaybe "Unknown" str
  setInnerHTML time lastupdate

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Map
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker roadmap (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng
  panTo roadmap latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_alt" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle = L.lookAngle
              (L.Coordinate fLat fLon fAlt)
              (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 40.371975 (-83.060578)
  roadmap <- gMap mapE (MapOptions { zoom: 10, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://mv-ws1.noexc.org:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker roadmap)
  --sendWS socket example

  where
    handleEvent e mvcA polyline marker roadmap = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker roadmap result.coordinates
          updateLookangle result.coordinates result.altitude
          updateTimestamp result.time
          updateTemperature result.temperature
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker roadmap) coordinates

updateTemperature ::
  forall eff.
  Celsius
  -> Eff (dom :: DOM | eff) Unit
updateTemperature temp = do
  doc <- document globalWindow
  Just tempField <- getElementById "temperature" doc
  setInnerHTML (show temp) tempField

updateTimestamp ::
  forall eff.
  String
  -> Eff (dom :: DOM, now :: MomentJS.Now | eff) Unit
updateTimestamp time = do
  doc <- document globalWindow
  --nowMoment <- now
  --let last = createMoment (momentConstructor time)
  Just lastupdate <- getElementById "lastupdate" doc
  --let str = liftMoment2 momentFrom nowMoment <$> last
  --let humanReadableTime = fromMaybe "Unknown" str
  setInnerHTML time lastupdate

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Map
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker roadmap (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng
  panTo roadmap latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_alt" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle = L.lookAngle
              (L.Coordinate fLat fLon fAlt)
              (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle


[CSE-79] Fix: Use unsecure connection

[CSE-79] Fix: Use unsecure connection

module Main where

import Prelude (($), (<$>), (<<<), bind, pure, const)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, nowDateTime)
import Control.SocketIO.Client (SocketIO, connect, on)
import Control.Comonad (extract)
import DOM (DOM)
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Socket (blocksUpdatedEventHandler, callYouEventHandler, callYouStringEventHandler, callYouCTxIdEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, txsUpdatedHandler) as Ex
import Explorer.Lenses.State (connection, socket)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..)) as Ex
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (hostname, secureProtocol)
import Explorer.View.Layout (view)
import Network.HTTP.Affjax (AJAX)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, Update, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)
import Signal (Signal, (~>))
import Signal.Time (every, second)
import Signal.Channel (channel, subscribe)

type AppEffects = (dom :: DOM, ajax :: AJAX, socket :: SocketIO, now :: NOW)

config :: Ex.State -> Eff (CoreEffects AppEffects) (Config Ex.State Ex.Action AppEffects)
config state = do
  -- routing
  urlSignal <- sampleUrl
  let routeSignal = urlSignal ~> Ex.UpdateView <<< match
  let clockSignal = every second ~> const Ex.UpdateClock
  -- socket
  actionChannel <- channel $ Ex.SocketConnected false
  let socketSignal = subscribe actionChannel :: Signal Ex.Action
  socketHost <- Ex.mkSocketHost (secureProtocol false) <$> hostname
  socket' <- connect socketHost
  on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
  on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
  on socket' (toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
  on socket' (toEvent BlocksUpdated) $ Ex.blocksUpdatedEventHandler actionChannel
  on socket' (toEvent CallYou) $ Ex.callYouEventHandler actionChannel
  on socket' (toEvent CallYouString) $ Ex.callYouStringEventHandler actionChannel
  on socket' (toEvent CallYouTxId) $ Ex.callYouCTxIdEventHandler actionChannel
  dt <- extract <$> nowDateTime

  pure
    { initialState: set (socket <<< connection) (Just socket') state
    , update: Ex.update :: Update Ex.State Ex.Action AppEffects
    , view: view
    , inputs: [clockSignal, socketSignal, routeSignal]
    }

appSelector :: String
appSelector = "#explorer"

main :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State Ex.Action)
main state = do
  app <- start =<< config state
  renderToDOM appSelector app.html
  pure app

debug :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State (Pux.Devtool.Action Ex.Action))
debug state = do
  appConfig <- config state
  app <- Pux.Devtool.start appConfig {opened: false}
  renderToDOM appSelector app.html
  pure app

module Main where

import Prelude (($), (<$>), (<<<), bind, pure, const)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, nowDateTime)
import Control.SocketIO.Client (SocketIO, connect, on)
import Control.Comonad (extract)
import DOM (DOM)
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Socket (blocksUpdatedEventHandler, callYouEventHandler, callYouStringEventHandler, callYouCTxIdEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, txsUpdatedHandler) as Ex
import Explorer.Lenses.State (connection, socket)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..)) as Ex
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (hostname, isProduction, secureProtocol)
import Explorer.View.Layout (view)
import Network.HTTP.Affjax (AJAX)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, Update, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)
import Signal (Signal, (~>))
import Signal.Time (every, second)
import Signal.Channel (channel, subscribe)

type AppEffects = (dom :: DOM, ajax :: AJAX, socket :: SocketIO, now :: NOW)

config :: Ex.State -> Eff (CoreEffects AppEffects) (Config Ex.State Ex.Action AppEffects)
config state = do
  -- routing
  urlSignal <- sampleUrl
  let routeSignal = urlSignal ~> Ex.UpdateView <<< match
  let clockSignal = every second ~> const Ex.UpdateClock
  -- socket
  actionChannel <- channel $ Ex.SocketConnected false
  let socketSignal = subscribe actionChannel :: Signal Ex.Action
  socketHost <- Ex.mkSocketHost (secureProtocol isProduction) <$> hostname
  socket' <- connect socketHost
  on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
  on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
  on socket' (toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
  on socket' (toEvent BlocksUpdated) $ Ex.blocksUpdatedEventHandler actionChannel
  on socket' (toEvent CallYou) $ Ex.callYouEventHandler actionChannel
  on socket' (toEvent CallYouString) $ Ex.callYouStringEventHandler actionChannel
  on socket' (toEvent CallYouTxId) $ Ex.callYouCTxIdEventHandler actionChannel
  dt <- extract <$> nowDateTime

  pure
    { initialState: set (socket <<< connection) (Just socket') state
    , update: Ex.update :: Update Ex.State Ex.Action AppEffects
    , view: view
    , inputs: [clockSignal, socketSignal, routeSignal]
    }

appSelector :: String
appSelector = "#explorer"

main :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State Ex.Action)
main state = do
  app <- start =<< config state
  renderToDOM appSelector app.html
  pure app

debug :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State (Pux.Devtool.Action Ex.Action))
debug state = do
  appConfig <- config state
  app <- Pux.Devtool.start appConfig {opened: false}
  renderToDOM appSelector app.html
  pure app


Fix chart eval dispatch (#1669)

Fix chart eval dispatch (#1669)

{-
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.Card.Eval
  ( runCard
  , modelToEval
  , module SlamData.Workspace.Card.Eval.Transition
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Writer.Class (class MonadTell)
import Data.StrMap (union)
import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL, class ParQuasarDSL)
import SlamData.Workspace.Card.Cache.Eval as Cache
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Chart.Eval as Chart
import SlamData.Workspace.Card.DownloadOptions.Eval as DOptions
import SlamData.Workspace.Card.Eval.Common as Common
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Eval.Transition (Eval(..), tagEval)
import SlamData.Workspace.Card.FormInput.Eval as FormInput
import SlamData.Workspace.Card.Markdown.Eval as MDE
import SlamData.Workspace.Card.Model as Model
import SlamData.Workspace.Card.Open.Eval as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Query.Eval as Query
import SlamData.Workspace.Card.Search.Eval as Search
import SlamData.Workspace.Card.Setups.Chart.Area.Eval as BuildArea
import SlamData.Workspace.Card.Setups.Chart.Bar.Eval as BuildBar
import SlamData.Workspace.Card.Setups.Chart.Boxplot.Eval as BuildBoxplot
import SlamData.Workspace.Card.Setups.Chart.Candlestick.Eval as BuildCandlestick
import SlamData.Workspace.Card.Setups.Chart.Funnel.Eval as BuildFunnel
import SlamData.Workspace.Card.Setups.Chart.Gauge.Eval as BuildGauge
import SlamData.Workspace.Card.Setups.Chart.Graph.Eval as BuildGraph
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Eval as BuildHeatmap
import SlamData.Workspace.Card.Setups.Chart.Line.Eval as BuildLine
import SlamData.Workspace.Card.Setups.Chart.Metric.Eval as BuildMetric
import SlamData.Workspace.Card.Setups.Chart.Parallel.Eval as BuildParallel
import SlamData.Workspace.Card.Setups.Chart.Pie.Eval as BuildPie
import SlamData.Workspace.Card.Setups.Chart.PivotTable.Eval as BuildPivotTable
import SlamData.Workspace.Card.Setups.Chart.PunchCard.Eval as BuildPunchCard
import SlamData.Workspace.Card.Setups.Chart.Radar.Eval as BuildRadar
import SlamData.Workspace.Card.Setups.Chart.Sankey.Eval as BuildSankey
import SlamData.Workspace.Card.Setups.Chart.Scatter.Eval as BuildScatter
import SlamData.Workspace.Card.Setups.FormInput.Date.Eval as SetupDate
import SlamData.Workspace.Card.Setups.FormInput.Datetime.Eval as SetupDatetime
import SlamData.Workspace.Card.Setups.FormInput.Labeled.Eval as SetupLabeled
import SlamData.Workspace.Card.Setups.FormInput.Numeric.Eval as SetupNumeric
import SlamData.Workspace.Card.Setups.FormInput.Static.Eval as SetupStatic
import SlamData.Workspace.Card.Setups.FormInput.Text.Eval as SetupText
import SlamData.Workspace.Card.Setups.FormInput.Time.Eval as SetupTime
import SlamData.Workspace.Card.Table.Eval as Table
import SlamData.Workspace.Card.Variables.Eval as VariablesE

runCard
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ Monad m
  ⇒ CEM.CardEnv
  → CEM.CardState
  → Eval
  → Port.Port
  → Port.DataMap
  → m (CEM.CardResult Port.Out)
runCard env state trans input varMap =
  CEM.runCardEvalM env state (evalCard trans input varMap ∷ CEM.CardEval Port.Out)

evalCard
  ∷ ∀ m
  . MonadAff SlamDataEffects m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ MonadState CEM.CardState m
  ⇒ MonadThrow CEM.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ ParQuasarDSL m
  ⇒ Eval
  → Port.Port
  → Port.DataMap
  → m Port.Out
evalCard trans port varMap = map (_ `union` varMap) <$> case trans, port of
  Error msg, _ → CEM.throw msg
  _, Port.CardError msg → CEM.throw msg
  Pass, _ → pure (port × varMap)
  Table m, _ → Table.eval m port varMap
  Chart, Port.ChartInstructions { options } → CEM.tapResource (Chart.eval options) varMap
  Chart, _ → pure (Port.ResourceKey Port.defaultResourceVar × varMap)
  Composite, _ → Port.varMapOut <$> Common.evalComposite
  Terminal, _ → pure Port.terminalOut
  Query sql, _ → Query.evalQuery sql varMap
  Markdown txt, _ → MDE.evalMarkdown txt varMap
  MarkdownForm model, Port.SlamDown doc → MDE.evalMarkdownForm model doc varMap
  Search query, _ → Search.evalSearch query =<< CEM.extractResource varMap
  Cache path, _ → Cache.eval path =<< CEM.extractResource varMap
  Open res, _ → Open.evalOpen res varMap
  Variables model, _ → VariablesE.eval model
  BuildMetric model, _ → CEM.tapResource (BuildMetric.eval model) varMap
  BuildSankey model, _ → BuildSankey.eval model =<< CEM.extractResource varMap
  BuildGauge model, _ → BuildGauge.eval model =<< CEM.extractResource varMap
  BuildGraph model, _ → BuildGraph.eval model =<< CEM.extractResource varMap
  BuildPie model, _ → BuildPie.eval model =<< CEM.extractResource varMap
  BuildRadar model, _ → BuildRadar.eval model =<< CEM.extractResource varMap
  BuildArea model, _ → BuildArea.eval model =<< CEM.extractResource varMap
  BuildLine model, _ → BuildLine.eval model =<< CEM.extractResource varMap
  BuildBar model, _ → BuildBar.eval model =<< CEM.extractResource varMap
  BuildScatter model, _ → BuildScatter.eval model =<< CEM.extractResource varMap
  BuildFunnel model, _ → BuildFunnel.eval model =<< CEM.extractResource varMap
  BuildHeatmap model, _ → BuildHeatmap.eval model =<< CEM.extractResource varMap
  BuildBoxplot model, _ → BuildBoxplot.eval model =<< CEM.extractResource varMap
  BuildPivotTable model, _ → BuildPivotTable.eval model varMap =<< CEM.extractResource varMap
  BuildPunchCard model, _ → BuildPunchCard.eval model =<< CEM.extractResource varMap
  BuildCandlestick model, _ → BuildCandlestick.eval model =<< CEM.extractResource varMap
  BuildParallel model, _ → BuildParallel.eval model =<< CEM.extractResource varMap
  SetupCheckbox model, _ → CEM.tapResource (SetupLabeled.eval model CT.Checkbox) varMap
  SetupRadio model, _ → CEM.tapResource (SetupLabeled.eval model CT.Radio) varMap
  SetupDropdown model, _ → CEM.tapResource (SetupLabeled.eval model CT.Dropdown) varMap
  SetupText model, _ → CEM.tapResource (SetupText.eval model) varMap
  SetupNumeric model, _ → CEM.tapResource (SetupNumeric.eval model) varMap
  SetupDate model, _ → CEM.tapResource (SetupDate.eval model) varMap
  SetupTime model, _ → CEM.tapResource (SetupTime.eval model) varMap
  SetupDatetime model, _ → CEM.tapResource (SetupDatetime.eval model) varMap
  SetupStatic model, _ → CEM.tapResource (SetupStatic.eval model) varMap
  FormInput (FormInput.Labeled model), Port.SetupLabeledFormInput lp →
    FormInput.evalLabeled model lp =<< CEM.extractResource varMap
  FormInput (FormInput.TextLike model), Port.SetupTextLikeFormInput tlp →
    FormInput.evalTextLike model tlp =<< CEM.extractResource varMap
  FormInput _, _ → pure (Port.ResourceKey Port.defaultResourceVar × varMap)
  DownloadOptions model, _ → CEM.tapResource (DOptions.eval model) varMap
  e, i → CEM.throw $ "Card received unexpected input type; " <> tagEval e <> " | " <> Port.tagPort i

modelToEval ∷ Model.AnyCardModel → Eval
modelToEval = case _ of
  Model.Ace CT.SQLMode model → Query model.text
  Model.Ace CT.MarkdownMode model → Markdown model.text
  Model.Markdown model → MarkdownForm model
  Model.Search txt → Search txt
  Model.Cache fp → Cache fp
  Model.Open res → Open res
  Model.Variables model → Variables model
  Model.DownloadOptions model → DownloadOptions model
  Model.Draftboard _ → Composite
  Model.BuildMetric model  → BuildMetric model
  Model.BuildSankey model → BuildSankey model
  Model.BuildGauge model → BuildGauge model
  Model.BuildGraph model → BuildGraph model
  Model.BuildPie model → BuildPie model
  Model.BuildRadar model → BuildRadar model
  Model.BuildArea model → BuildArea model
  Model.BuildLine model → BuildLine model
  Model.BuildBar model → BuildBar model
  Model.BuildScatter model → BuildScatter model
  Model.BuildFunnel model → BuildFunnel model
  Model.BuildHeatmap model → BuildHeatmap model
  Model.BuildBoxplot model → BuildBoxplot model
  Model.BuildPivotTable model → BuildPivotTable model
  Model.BuildPunchCard model → BuildPunchCard model
  Model.BuildCandlestick model → BuildCandlestick model
  Model.BuildParallel model → BuildParallel model
  Model.Chart _ → Chart
  Model.SetupDropdown model → SetupDropdown model
  Model.SetupStatic model → SetupStatic model
  Model.SetupText model → SetupText model
  Model.SetupNumeric model → SetupNumeric model
  Model.SetupCheckbox model → SetupCheckbox model
  Model.SetupRadio model → SetupRadio model
  Model.SetupDate model → SetupDate model
  Model.SetupTime model → SetupTime model
  Model.SetupDatetime model → SetupDatetime model
  Model.FormInput model → FormInput model
  Model.Tabs _ → Terminal
  Model.Table model → Table model
  _ → Pass

{-
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.Card.Eval
  ( runCard
  , modelToEval
  , module SlamData.Workspace.Card.Eval.Transition
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Writer.Class (class MonadTell)
import Data.StrMap (union)
import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL, class ParQuasarDSL)
import SlamData.Workspace.Card.Cache.Eval as Cache
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Chart.Eval as Chart
import SlamData.Workspace.Card.DownloadOptions.Eval as DOptions
import SlamData.Workspace.Card.Eval.Common as Common
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Eval.Transition (Eval(..), tagEval)
import SlamData.Workspace.Card.FormInput.Eval as FormInput
import SlamData.Workspace.Card.Markdown.Eval as MDE
import SlamData.Workspace.Card.Model as Model
import SlamData.Workspace.Card.Open.Eval as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Query.Eval as Query
import SlamData.Workspace.Card.Search.Eval as Search
import SlamData.Workspace.Card.Setups.Chart.Area.Eval as BuildArea
import SlamData.Workspace.Card.Setups.Chart.Bar.Eval as BuildBar
import SlamData.Workspace.Card.Setups.Chart.Boxplot.Eval as BuildBoxplot
import SlamData.Workspace.Card.Setups.Chart.Candlestick.Eval as BuildCandlestick
import SlamData.Workspace.Card.Setups.Chart.Funnel.Eval as BuildFunnel
import SlamData.Workspace.Card.Setups.Chart.Gauge.Eval as BuildGauge
import SlamData.Workspace.Card.Setups.Chart.Graph.Eval as BuildGraph
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Eval as BuildHeatmap
import SlamData.Workspace.Card.Setups.Chart.Line.Eval as BuildLine
import SlamData.Workspace.Card.Setups.Chart.Metric.Eval as BuildMetric
import SlamData.Workspace.Card.Setups.Chart.Parallel.Eval as BuildParallel
import SlamData.Workspace.Card.Setups.Chart.Pie.Eval as BuildPie
import SlamData.Workspace.Card.Setups.Chart.PivotTable.Eval as BuildPivotTable
import SlamData.Workspace.Card.Setups.Chart.PunchCard.Eval as BuildPunchCard
import SlamData.Workspace.Card.Setups.Chart.Radar.Eval as BuildRadar
import SlamData.Workspace.Card.Setups.Chart.Sankey.Eval as BuildSankey
import SlamData.Workspace.Card.Setups.Chart.Scatter.Eval as BuildScatter
import SlamData.Workspace.Card.Setups.FormInput.Date.Eval as SetupDate
import SlamData.Workspace.Card.Setups.FormInput.Datetime.Eval as SetupDatetime
import SlamData.Workspace.Card.Setups.FormInput.Labeled.Eval as SetupLabeled
import SlamData.Workspace.Card.Setups.FormInput.Numeric.Eval as SetupNumeric
import SlamData.Workspace.Card.Setups.FormInput.Static.Eval as SetupStatic
import SlamData.Workspace.Card.Setups.FormInput.Text.Eval as SetupText
import SlamData.Workspace.Card.Setups.FormInput.Time.Eval as SetupTime
import SlamData.Workspace.Card.Table.Eval as Table
import SlamData.Workspace.Card.Variables.Eval as VariablesE

runCard
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ Monad m
  ⇒ CEM.CardEnv
  → CEM.CardState
  → Eval
  → Port.Port
  → Port.DataMap
  → m (CEM.CardResult Port.Out)
runCard env state trans input varMap =
  CEM.runCardEvalM env state (evalCard trans input varMap ∷ CEM.CardEval Port.Out)

evalCard
  ∷ ∀ m
  . MonadAff SlamDataEffects m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ MonadState CEM.CardState m
  ⇒ MonadThrow CEM.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ ParQuasarDSL m
  ⇒ Eval
  → Port.Port
  → Port.DataMap
  → m Port.Out
evalCard trans port varMap = map (_ `union` varMap) <$> case trans, port of
  Error msg, _ → CEM.throw msg
  _, Port.CardError msg → CEM.throw msg
  Pass, _ → pure (port × varMap)
  Table m, _ → Table.eval m port varMap
  Chart, Port.ChartInstructions { options } → CEM.tapResource (Chart.eval options) varMap
  Composite, _ → Port.varMapOut <$> Common.evalComposite
  Terminal, _ → pure Port.terminalOut
  Query sql, _ → Query.evalQuery sql varMap
  Markdown txt, _ → MDE.evalMarkdown txt varMap
  MarkdownForm model, Port.SlamDown doc → MDE.evalMarkdownForm model doc varMap
  Search query, _ → Search.evalSearch query =<< CEM.extractResource varMap
  Cache path, _ → Cache.eval path =<< CEM.extractResource varMap
  Open res, _ → Open.evalOpen res varMap
  Variables model, _ → VariablesE.eval model
  BuildMetric model, _ → CEM.tapResource (BuildMetric.eval model) varMap
  BuildSankey model, _ → BuildSankey.eval model =<< CEM.extractResource varMap
  BuildGauge model, _ → BuildGauge.eval model =<< CEM.extractResource varMap
  BuildGraph model, _ → BuildGraph.eval model =<< CEM.extractResource varMap
  BuildPie model, _ → BuildPie.eval model =<< CEM.extractResource varMap
  BuildRadar model, _ → BuildRadar.eval model =<< CEM.extractResource varMap
  BuildArea model, _ → BuildArea.eval model =<< CEM.extractResource varMap
  BuildLine model, _ → BuildLine.eval model =<< CEM.extractResource varMap
  BuildBar model, _ → BuildBar.eval model =<< CEM.extractResource varMap
  BuildScatter model, _ → BuildScatter.eval model =<< CEM.extractResource varMap
  BuildFunnel model, _ → BuildFunnel.eval model =<< CEM.extractResource varMap
  BuildHeatmap model, _ → BuildHeatmap.eval model =<< CEM.extractResource varMap
  BuildBoxplot model, _ → BuildBoxplot.eval model =<< CEM.extractResource varMap
  BuildPivotTable model, _ → BuildPivotTable.eval model varMap =<< CEM.extractResource varMap
  BuildPunchCard model, _ → BuildPunchCard.eval model =<< CEM.extractResource varMap
  BuildCandlestick model, _ → BuildCandlestick.eval model =<< CEM.extractResource varMap
  BuildParallel model, _ → BuildParallel.eval model =<< CEM.extractResource varMap
  SetupCheckbox model, _ → CEM.tapResource (SetupLabeled.eval model CT.Checkbox) varMap
  SetupRadio model, _ → CEM.tapResource (SetupLabeled.eval model CT.Radio) varMap
  SetupDropdown model, _ → CEM.tapResource (SetupLabeled.eval model CT.Dropdown) varMap
  SetupText model, _ → CEM.tapResource (SetupText.eval model) varMap
  SetupNumeric model, _ → CEM.tapResource (SetupNumeric.eval model) varMap
  SetupDate model, _ → CEM.tapResource (SetupDate.eval model) varMap
  SetupTime model, _ → CEM.tapResource (SetupTime.eval model) varMap
  SetupDatetime model, _ → CEM.tapResource (SetupDatetime.eval model) varMap
  SetupStatic model, _ → CEM.tapResource (SetupStatic.eval model) varMap
  FormInput (FormInput.Labeled model), Port.SetupLabeledFormInput lp →
    FormInput.evalLabeled model lp =<< CEM.extractResource varMap
  FormInput (FormInput.TextLike model), Port.SetupTextLikeFormInput tlp →
    FormInput.evalTextLike model tlp =<< CEM.extractResource varMap
  FormInput _, _ → pure (Port.ResourceKey Port.defaultResourceVar × varMap)
  DownloadOptions model, _ → CEM.tapResource (DOptions.eval model) varMap
  e, i → CEM.throw $ "Card received unexpected input type; " <> tagEval e <> " | " <> Port.tagPort i

modelToEval ∷ Model.AnyCardModel → Eval
modelToEval = case _ of
  Model.Ace CT.SQLMode model → Query model.text
  Model.Ace CT.MarkdownMode model → Markdown model.text
  Model.Markdown model → MarkdownForm model
  Model.Search txt → Search txt
  Model.Cache fp → Cache fp
  Model.Open res → Open res
  Model.Variables model → Variables model
  Model.DownloadOptions model → DownloadOptions model
  Model.Draftboard _ → Composite
  Model.BuildMetric model  → BuildMetric model
  Model.BuildSankey model → BuildSankey model
  Model.BuildGauge model → BuildGauge model
  Model.BuildGraph model → BuildGraph model
  Model.BuildPie model → BuildPie model
  Model.BuildRadar model → BuildRadar model
  Model.BuildArea model → BuildArea model
  Model.BuildLine model → BuildLine model
  Model.BuildBar model → BuildBar model
  Model.BuildScatter model → BuildScatter model
  Model.BuildFunnel model → BuildFunnel model
  Model.BuildHeatmap model → BuildHeatmap model
  Model.BuildBoxplot model → BuildBoxplot model
  Model.BuildPivotTable model → BuildPivotTable model
  Model.BuildPunchCard model → BuildPunchCard model
  Model.BuildCandlestick model → BuildCandlestick model
  Model.BuildParallel model → BuildParallel model
  Model.Chart _ → Chart
  Model.SetupDropdown model → SetupDropdown model
  Model.SetupStatic model → SetupStatic model
  Model.SetupText model → SetupText model
  Model.SetupNumeric model → SetupNumeric model
  Model.SetupCheckbox model → SetupCheckbox model
  Model.SetupRadio model → SetupRadio model
  Model.SetupDate model → SetupDate model
  Model.SetupTime model → SetupTime model
  Model.SetupDatetime model → SetupDatetime model
  Model.FormInput model → FormInput model
  Model.Tabs _ → Terminal
  Model.Table model → Table model
  _ → Pass


fixed next action card update

fixed next action card update

{-
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.Card.Next.Component
 ( nextCardComponent
 , Message(..)
 , module SlamData.Workspace.Card.Next.Component.Query
 , module SlamData.Workspace.Card.Next.Component.State
 , module NA
 ) where

import SlamData.Prelude

import CSS as CSS

import Data.Lens ((.~))

import Halogen as H
import Halogen.HTML.CSS as HCSS
import Halogen.HTML as HH

import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Monad (Slam)
import SlamData.Guide.Notification as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.ChildSlot as CS
import SlamData.Workspace.Card.Next.Component.Query (Query(..))
import SlamData.Workspace.Card.Next.Component.State (State, initialState)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port

import Utils.LocalStorage as LocalStorage

type HTML =
  H.ParentHTML Query CS.ChildQuery CS.ChildSlot Slam

type DSL =
  H.ParentDSL State Query CS.ChildQuery CS.ChildSlot Message Slam

data Message
  = AddCard CT.CardType
  | PresentReason Port.Port CT.CardType

nextCardComponent ∷ H.Component HH.HTML Query Port.Port Message Slam
nextCardComponent = H.parentComponent
  { initialState
  , render
  , eval
  , receiver: const Nothing
  }

render ∷ State → HTML
render state =
  HH.div
    [ HCSS.style $ CSS.width (CSS.pct 100.0) *> CSS.height (CSS.pct 100.0) ]
    $ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.ClassName "sd-add-card-guide")
          (DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.slot' CS.cpActionFilter unit
          ActionFilter.component
          "Filter next actions"
          case _ of
            ActionFilter.FilterChanged str →
              Just $ H.action $ HandleFilter str
      , HH.slot' CS.cpActionList unit
          (ActionList.actionListComp ActionList.defaultConf (NA.fromPort state.input))
          unit
          case _ of
            ActionList.Selected a →
              Just $ H.action $ HandleAction a
      ]
  where
  addCardGuideText = case _ of
    Port.Initial → "To get this deck started press one of these buttons to add a card."
    _            → "To do more with this deck press one of these buttons to add a card."

updateActions ∷ Port.Port → DSL Unit
updateActions =
  void
    ∘ H.query' CS.cpActionList unit
    ∘ H.action
    ∘ ActionList.UpdateActions
    ∘ NA.fromPort

takesInput ∷ Port.Port → CT.CardType → Boolean
takesInput input =
  ICT.takesInput (ICT.fromPort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  ICT.possibleToGetTo (ICT.fromPort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ DSL Boolean
getDismissedAddCardGuideBefore =
  H.lift $ either (const $ false) id <$>
    LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ DSL Unit
storeDismissedAddCardGuide =
  H.lift $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ DSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false)
    *> storeDismissedAddCardGuide

eval ∷ Query ~> DSL
eval = case _ of
  UpdateInput input next → updateActions input $> next
  DismissAddCardGuide next → dismissAddCardGuide $> next
  PresentAddCardGuide next → do
    H.modify
      ∘ (State._presentAddCardGuide .~ _)
      ∘ not =<< getDismissedAddCardGuideBefore
    pure next
  HandleFilter str next → do
    H.query' CS.cpActionList unit
      $ H.action
      $ ActionList.UpdateFilter str
    pure next
  HandleAction act next → do
    case act of
      NA.Insert cardType → do
        dismissAddCardGuide
        H.raise $ AddCard cardType
      NA.FindOutHowToInsert cardType → do
        input ← H.gets _.input
        H.raise $ PresentReason input cardType
    pure next
  ToActionList query → unsafePartial do
    Just res ← H.query' CS.cpActionList unit query
    pure res

{-
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.Card.Next.Component
 ( nextCardComponent
 , Message(..)
 , module SlamData.Workspace.Card.Next.Component.Query
 , module SlamData.Workspace.Card.Next.Component.State
 , module NA
 ) where

import SlamData.Prelude

import CSS as CSS

import Data.Lens ((.~))

import Halogen as H
import Halogen.HTML.CSS as HCSS
import Halogen.HTML as HH
import Halogen.HTML.Events as HE

import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Monad (Slam)
import SlamData.Guide.Notification as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.ChildSlot as CS
import SlamData.Workspace.Card.Next.Component.Query (Query(..))
import SlamData.Workspace.Card.Next.Component.State (State, initialState)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port

import Utils.LocalStorage as LocalStorage

type HTML =
  H.ParentHTML Query CS.ChildQuery CS.ChildSlot Slam

type DSL =
  H.ParentDSL State Query CS.ChildQuery CS.ChildSlot Message Slam

data Message
  = AddCard CT.CardType
  | PresentReason Port.Port CT.CardType

nextCardComponent ∷ H.Component HH.HTML Query Port.Port Message Slam
nextCardComponent = H.parentComponent
  { initialState
  , render
  , eval
  , receiver: HE.input UpdateInput
  }

render ∷ State → HTML
render state =
  HH.div
    [ HCSS.style $ CSS.width (CSS.pct 100.0) *> CSS.height (CSS.pct 100.0) ]
    $ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.ClassName "sd-add-card-guide")
          (DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.slot' CS.cpActionFilter unit
          ActionFilter.component
          "Filter next actions"
          case _ of
            ActionFilter.FilterChanged str →
              Just $ H.action $ HandleFilter str
      , HH.slot' CS.cpActionList unit
          (ActionList.actionListComp ActionList.defaultConf (NA.fromPort state.input))
          unit
          case _ of
            ActionList.Selected a →
              Just $ H.action $ HandleAction a
      ]
  where
  addCardGuideText = case _ of
    Port.Initial → "To get this deck started press one of these buttons to add a card."
    _            → "To do more with this deck press one of these buttons to add a card."

updateActions ∷ Port.Port → DSL Unit
updateActions =
  void
    ∘ H.query' CS.cpActionList unit
    ∘ H.action
    ∘ ActionList.UpdateActions
    ∘ NA.fromPort

takesInput ∷ Port.Port → CT.CardType → Boolean
takesInput input =
  ICT.takesInput (ICT.fromPort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  ICT.possibleToGetTo (ICT.fromPort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ DSL Boolean
getDismissedAddCardGuideBefore =
  H.lift $ either (const $ false) id <$>
    LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ DSL Unit
storeDismissedAddCardGuide =
  H.lift $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ DSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false)
    *> storeDismissedAddCardGuide

eval ∷ Query ~> DSL
eval = case _ of
  UpdateInput input next → updateActions input $> next
  DismissAddCardGuide next → dismissAddCardGuide $> next
  PresentAddCardGuide next → do
    H.modify
      ∘ (State._presentAddCardGuide .~ _)
      ∘ not =<< getDismissedAddCardGuideBefore
    pure next
  HandleFilter str next → do
    H.query' CS.cpActionList unit
      $ H.action
      $ ActionList.UpdateFilter str
    pure next
  HandleAction act next → do
    case act of
      NA.Insert cardType → do
        dismissAddCardGuide
        H.raise $ AddCard cardType
      NA.FindOutHowToInsert cardType → do
        input ← H.gets _.input
        H.raise $ PresentReason input cardType
    pure next
  ToActionList query → unsafePartial do
    Just res ← H.query' CS.cpActionList unit query
    pure res


use tabs

use tabs

module Main where

import Debug.Trace

import Data.Maybe

import qualified Thermite as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T
import qualified Thermite.Events as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T

import Models.Group
import Models.Channel

type State =
	{ counter :: Number
	}

data Action
	= Increment
	| Decrement

spec :: T.Spec (T.Action _ State) State Unit Action
spec = T.Spec
	{ displayName : Just "chatty"
	, render: render
	, performAction: performAction
	, initialState: initialState
	, componentWillMount: Nothing
	}

render :: T.Render State Unit Action
render ctx st _ =
	container
		[
			header [],
			body
				[
					E.p'
						[
							E.p' [ H.text (show st.counter) ],
							E.button [ T.onClick ctx (const Increment)] [ H.text "Increment" ],
							E.button [ T.onClick ctx (const Decrement)] [ H.text "Decrement" ]
						]
				]
		]
	where
		container = E.div [ A.className "container" ]
		header = E.div [ A.className "header" ]
		body = E.div [ A.className "body" ]

performAction :: T.PerformAction Unit Action (T.Action _ State)
performAction _ Increment = T.modifyState \st -> { counter: st.counter + 1 }
performAction _ Decrement = T.modifyState \st -> { counter: st.counter - 1 }

initialState :: State
initialState =
	{ counter: 0
	}

main = do
	let cl = T.createClass spec
	T.render cl unit


Cleanup based on warnings from pulp

Cleanup based on warnings from pulp

module Main where

import Prelude
import Control.Monad.Eff
import DOM
import Signal
import Signal.DOM
import Signal.Time (every)
import Data.Foldable (foldl)
import Text.Smolder.Markup
import qualified Text.Smolder.HTML as H
import qualified Text.Smolder.HTML.Attributes as A
import Text.Smolder.Renderer.String (render)

data Color = White | Red | Blue | Green | Cyan
type PlayerState = { x :: Int, y :: Int, color :: Color }
type MouseInput = { x :: Int, y :: Int, isClicked :: Boolean }

frameRate :: Signal Number
frameRate = every 60.0

initialPlayerOne :: PlayerState
initialPlayerOne = { x: 0, y: 0, color: White }

updatePlayer :: MouseInput -> PlayerState -> PlayerState
updatePlayer ({x: newX, y: newY, isClicked: clicked}) ({color: currentColor}) =
    { x: newX, y: newY, color: newColor }
        where
            newColor = updateColor clicked currentColor
            updateColor :: Boolean -> Color -> Color
            updateColor false c     = c
            updateColor true  White = Red
            updateColor true  Red   = Blue
            updateColor true  Blue  = Green
            updateColor true  Green = Cyan
            updateColor true  Cyan  = White

renderColor :: Color -> String
renderColor White = "#fff"
renderColor Red   = "#f00"
renderColor Blue  = "#00f"
renderColor Green = "#0f0"
renderColor Cyan  = "#77f"

renderPlayer ::  PlayerState -> Markup
renderPlayer ({x: currentX, y: currentY, color: currentColor}) =
    H.div ! (A.style currentStyle) ! (A.id "playerOne") $ do text ""
    where
        currentStyle = foldl (++) "" [
            (" background-color: " ++ (renderColor currentColor)) ++ "; ",
            (" top: "  ++ (show currentY) ++ "px; "),
            (" left: " ++ (show currentX) ++ "px; "),
            (" position: absolute; ")
        ]

-- asBody replaces the contents of the <body> with the given HTML.
-- There's probably a faster rendering method.
foreign import asBody :: forall eff. String -> Eff (dom:: DOM | eff) Unit

playerOne :: Signal MouseInput -> Signal PlayerState
playerOne mouseInputSignal = foldp updatePlayer initialPlayerOne (sampleOn frameRate mouseInputSignal)

main :: forall eff. Eff (dom :: DOM | eff) Unit
main = do
    -- mousePos and mouseButton both wrap their signals in a nasty Eff monad
    -- so the value I care about is two layers deep. So we get them here in do-notation-land.
    mousePosSignal <- mousePos
    leftClickSignal <- mouseButton 0
    let mouseSignal = combineMouseSignals <~ mousePosSignal ~ leftClickSignal
    runSignal (playerOne mouseSignal ~> (renderPlayer >>> render >>> asBody))
    where
        combineMouseSignals :: CoordinatePair -> Boolean -> MouseInput
        combineMouseSignals pos clicked = {x: pos.x, y: pos.y, isClicked: clicked}

module Main where

import Prelude
import Control.Monad.Eff
import DOM
import Signal
import Signal.DOM
import Signal.Time (every)
import Data.Tuple
import Data.Foldable (foldl)
import Text.Smolder.Markup
import qualified Text.Smolder.HTML as H
import qualified Text.Smolder.HTML.Attributes as A
import Text.Smolder.Renderer.String (render)

data Color = White | Red | Blue | Green | Cyan
type PlayerState = { x :: Int, y :: Int, color :: Color }
type MouseInput = { x :: Int, y :: Int, isClicked :: Boolean }

frameRate :: Signal Number
frameRate = every 60.0

initialPlayerOne :: PlayerState
initialPlayerOne = { x: 0, y: 0, color: White }

updatePlayer :: MouseInput -> PlayerState -> PlayerState
updatePlayer ({x: newX, y: newY, isClicked: clicked}) ({color: currentColor}) =
    { x: newX, y: newY, color: newColor }
        where
            newColor = updateColor clicked currentColor
            updateColor :: Boolean -> Color -> Color
            updateColor false c     = c
            updateColor true  White = Red
            updateColor true  Red   = Blue
            updateColor true  Blue  = Green
            updateColor true  Green = Cyan
            updateColor true  Cyan  = White

renderColor :: Color -> String
renderColor White = "#fff"
renderColor Red   = "#f00"
renderColor Blue  = "#00f"
renderColor Green = "#0f0"
renderColor Cyan  = "#77f"

renderPlayer ::  PlayerState -> Markup
renderPlayer ({x: currentX, y: currentY, color: currentColor}) =
    H.div ! (A.style currentStyle) ! (A.id "playerOne") $ do text ""
    where
        currentStyle = foldl (++) "" [
            (" background-color: " ++ (renderColor currentColor)) ++ "; ",
            (" top: "  ++ (show currentY) ++ "px; "),
            (" left: " ++ (show currentX) ++ "px; "),
            (" position: absolute; ")
        ]

-- asBody replaces the contents of the <body> with the given HTML.
-- There's probably a faster rendering method.
foreign import asBody :: forall eff. String -> Eff (dom:: DOM | eff) Unit

playerOne :: Signal MouseInput -> Signal PlayerState
playerOne mouseInputSignal = foldp updatePlayer initialPlayerOne (sampleOn frameRate mouseInputSignal)

main = do
    -- mousePos and mouseButton both wrap their signals in a nasty Eff monad
    -- so the value I care about is two layers deep. So we get them here in do-notation-land.
    mousePosSignal <- mousePos
    leftClickSignal <- mouseButton 0
    let mouseSignal = combineMouseSignals <~ mousePosSignal ~ leftClickSignal
    runSignal (playerOne mouseSignal ~> (renderPlayer >>> render >>> asBody))
    where
        combineMouseSignals :: CoordinatePair -> Boolean -> MouseInput
        combineMouseSignals pos clicked = {x: pos.x, y: pos.y, isClicked: clicked}


tbody

tbody

module List where

import Api
import Helper
import Types
import React
import React.DOM
import Data.Maybe
import Data.JSON(decode)
import Data.Tuple
import Control.Monad.Cont.Trans(runContT)
import qualified Data.Map as M
import Dispatcher

renderListHead:: Row -> React.UI
renderListHead (Row x) = tr' ((th' <<< pure <<< text) <$> M.keys x)

renderListItem :: Row -> React.UI
renderListItem (Row x) = tr' ((td' <<< pure <<< text) <$> (M.values $ unpackedJValueMap x))

makeRows :: [Row] -> [React.UI]
makeRows xs = ((getTheTopRow xs) : (renderComponents xs))
  where
    getTheTopRow (x:xs) = renderListHead x
    renderComponents xs = renderListItem <$> xs

makeFormState :: Maybe [Row] -> [React.UI]
makeFormState = maybe [] makeRows

getData baseUrl tablename = (makeFormState <<< decode) <$> (http' urls.index)
  where
    urls :: URLS
    urls = createUrls baseUrl tablename

getDataRunState self baseUrl n = do
  runContT (getData baseUrl n) \s -> do
    runUI self $ do
      writeState (Tuple n s)
      return unit

reloadTable self baseUrl _ = do
    runUI self $ do
      (Tuple n _) <- readState
      runContT (getData baseUrl n) \s -> do
        runUI self $ do
          (Tuple name _) <- readState
          writeState (Tuple n s)
          return unit

theList :: String -> {} -> React.UI
theList baseUrl = mkUI spec {
    getInitialState = return (Tuple "" []),
    componentDidMount = do
      self <- getSelf
      return $ register "created" (reloadTable self baseUrl)
      return $ register "navClick" (getDataRunState self baseUrl)
  } do
    (Tuple name rows) <- readState
    return $ table [
        className "list table table-bordered table-striped"
      ] [tbody' $ rows]

widget baseUrl = theList baseUrl {}

module List where

import Api
import Helper
import Types
import React
import React.DOM
import Data.Maybe
import Data.JSON(decode)
import Data.Tuple
import Control.Monad.Cont.Trans(runContT)
import qualified Data.Map as M
import Dispatcher

renderListHead:: Row -> React.UI
renderListHead (Row x) = tr' ((th' <<< pure <<< text) <$> M.keys x)

renderListItem :: Row -> React.UI
renderListItem (Row x) = tr' ((td' <<< pure <<< text) <$> (M.values $ unpackedJValueMap x))

makeRows :: [Row] -> [React.UI]
makeRows xs = ((getTheTopRow xs) : (renderComponents xs))
  where
    getTheTopRow (x:xs) = renderListHead x
    renderComponents xs = renderListItem <$> xs

makeFormState :: Maybe [Row] -> [React.UI]
makeFormState = maybe [] makeRows

getData baseUrl tablename = (makeFormState <<< decode) <$> (http' urls.index)
  where
    urls :: URLS
    urls = createUrls baseUrl tablename

getDataRunState self baseUrl n = do
  runContT (getData baseUrl n) \s -> do
    runUI self $ do
      writeState (Tuple n s)
      return unit

reloadTable self baseUrl _ = do
    runUI self $ do
      (Tuple n _) <- readState
      runContT (getData baseUrl n) \s -> do
        runUI self $ do
          (Tuple name _) <- readState
          writeState (Tuple n s)
          return unit

theList :: String -> {} -> React.UI
theList baseUrl = mkUI spec {
    getInitialState = return (Tuple "" []),
    componentDidMount = do
      self <- getSelf
      return $ register "created" (reloadTable self baseUrl)
      return $ register "navClick" (getDataRunState self baseUrl)
  } do
    (Tuple name rows) <- readState
    return $ table [
        className "list table table-bordered table-striped"
      ] rows

widget baseUrl = theList baseUrl {}


type of main - borrowed from Pux Starter App

module App where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff
import DOM (DOM)
import Signal.Channel (CHANNEL)
import Prelude(bind, return)
import Pux (App, start, fromSimple, renderToDOM)
import App.Counter (State, Action, update, view)

type AppEffects eff = (err :: EXCEPTION, channel :: CHANNEL | eff)

main :: State -> Eff (AppEffects (dom :: DOM)) (App State Action)
main state = do
  app <- start
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs: []
    }
  renderToDOM "#app" app.html
  return app

module App where

import App.Counter (update, view)
import Prelude(bind, return)
import Control.Monad.Eff
import Pux (start, fromSimple, renderToDOM)

main state = do
  app <- start
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs: []
    }
  renderToDOM "#app" app.html
  return app


Tidy

Tidy

Original commit 8cfbcad237665dad6bb8037bcf17bb5bcfdd9905

module Doc
    ( Doc
    , Renderer
    , Transforms
    , getTopLevel
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import Prelude

import IR
import IRGraph

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Foldable (for_)
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.Tuple (Tuple(..), snd)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type Transforms =
    { nameForClass :: IRClassData -> String
    , unionName :: List String -> String
    , unionPredicate :: IRType -> Maybe (Set IRType)
    , nextName :: String -> String
    , forbiddenNames :: Array String
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map (Set IRType) String
    , unions :: List (Set IRType)
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph =
    let classes = classesInGraph graph
        forbidden = S.fromFoldable t.forbiddenNames
        classNames = transformNames t.nameForClass t.nextName forbidden classes
        unions = L.fromFoldable $ filterTypes t.unionPredicate graph
        forbiddenForUnions = S.union forbidden $ S.fromFoldable $ M.values classNames
        nameForUnion s = t.unionName $ map (typeNameForUnion graph) $ L.sort $ L.fromFoldable s
        unionNames = transformNames nameForUnion t.nextName forbiddenForUnions $ map (\s -> Tuple s s) unions
    in
        evalRWS w { graph, classNames, unionNames, unions } { indent: 0 } # snd

typeNameForUnion :: IRGraph -> IRType -> String
typeNameForUnion graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in combineNames names
    IRMap t -> typeNameForUnion graph t <> "_map"
    IRUnion _ -> "union"

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  pure $ typeNameForUnion g typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevel :: Doc IRType
getTopLevel = do
    IRGraph { toplevel } <- getGraph
    pure toplevel

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List (Set IRType))
getUnions = Doc (asks _.unions)

getUnionNames :: Doc (Map (Set IRType) String)
getUnionNames = Doc (asks _.unionNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = classesInGraph <$> getGraph

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = times "\t" indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

-- Cannot make this work any other way!
times :: String -> Int -> String
times s n | n < 1 = ""
times s 1 = s
times s n = s <> times s (n - 1)

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a


Error tests

Error tests

module Test.Main where

import Prelude
import Main

import Test.Unit (suite, test, timeout, success, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Assert as Assert

import Data.Either
import Control.Monad.Eff (Eff)
import Control.Monad.Aff
import Control.Monad.Eff.Class --liftEff
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throwException)

--main :: forall e. Eff (assert::ASSERT, err::EXCEPTION, console :: CONSOLE | e) Unit
main = runTest do
  suite "convertToWsUrl" do
    test "Port+Path+File+Query" do
      url <- liftEff $ convertToWsUrl "http://localhost:12000/static/index.html?q=123"
      Assert.equal url "ws://localhost:12000/ws/stats"
    test "Port+Path" do
      url <- liftEff $ convertToWsUrl "http://localhost:12000/static/"
      Assert.equal url "ws://localhost:12000/ws/stats"
    test "Port+EmptyPath" do
      url <- liftEff $ convertToWsUrl "http://test.org:80/"
      Assert.equal url "ws://test.org:80/ws/stats"
    test "Port" do
      url <- liftEff $ convertToWsUrl "http://test.org:80"
      Assert.equal url "ws://test.org:80/ws/stats"
    test "Relative" do
      e <- liftEff' $ convertToWsUrl "/static/index.html"
      either (const success) (\r -> failure $ "Converted invalid URL to " <> r) e

module Test.Main where

import Prelude
import Main

import Test.Unit (suite, test, timeout)
import Test.Unit.Main (runTest)
import Test.Unit.Assert as Assert

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throwException)

--main :: forall e. Eff (assert::ASSERT, err::EXCEPTION, console :: CONSOLE | e) Unit
main = runTest do
  suite "convertToWsUrl" do
    test "Port+Path+Query" do
      url1 <- liftEff $ convertToWsUrl "http://localhost:12000/static/index.html?q=123"
      Assert.equal url1 "ws://localhost:12000/ws/stats"
    test "Port+EmptyPath" do
      url2 <- liftEff $ convertToWsUrl "http://test.org:80/"
      Assert.equal url2 "ws://test.org:80/ws/stats"
    test "Port" do
      url3 <- liftEff $ convertToWsUrl "http://test.org:80"
      Assert.equal url3 "ws://test.org:80/ws/stats"