scheduler: support ERROR messages

scheduler: support ERROR messages

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.Foreign.Undefined (Undefined(..))
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe, maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID, TaskStatus, AgentID, ExecutorID, readPropNU)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

newtype Failure = Failure
    { slaveId :: Maybe AgentID
    , executorId :: Maybe ExecutorID
    , status :: Maybe Int
    }

instance failureAsForeign :: AsForeign Failure where
    write (Failure obj) = writeObject props where
        props = [ "agent_id" .= (write $ Undefined obj.slaveId)
                , "executor_id" .= (write $ Undefined obj.executorId)
                , "status" .= (write $ Undefined obj.status)
                ]

instance failureIsForeign :: IsForeign Failure where
    read obj = do
        slaveId <- catchError (readPropNU "agent_id" obj) \_ -> readPropNU "slave_id" obj
        executorId <- readPropNU "executor_id" obj
        status <- readPropNU "status" obj
        pure <<< Failure $
            { slaveId: slaveId
            , executorId: executorId
            , status: status
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | FailureMessage Failure
             | ErrorMessage String
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write (FailureMessage failure) = writeMessage "FAILURE" "failure" failure
    write (ErrorMessage msg) = toForeign $
        { type: "ERROR"
        , message: msg
        }
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "FAILURE" = FailureMessage <$> readProp "failure" value
        readMessageType "ERRROR" = ErrorMessage <$> readProp "message" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.Foreign.Undefined (Undefined(..))
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe, maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID, TaskStatus, AgentID, ExecutorID, readPropNU)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

newtype Failure = Failure
    { slaveId :: Maybe AgentID
    , executorId :: Maybe ExecutorID
    , status :: Maybe Int
    }

instance failureAsForeign :: AsForeign Failure where
    write (Failure obj) = writeObject props where
        props = [ "agent_id" .= (write $ Undefined obj.slaveId)
                , "executor_id" .= (write $ Undefined obj.executorId)
                , "status" .= (write $ Undefined obj.status)
                ]

instance failureIsForeign :: IsForeign Failure where
    read obj = do
        slaveId <- catchError (readPropNU "agent_id" obj) \_ -> readPropNU "slave_id" obj
        executorId <- readPropNU "executor_id" obj
        status <- readPropNU "status" obj
        pure <<< Failure $
            { slaveId: slaveId
            , executorId: executorId
            , status: status
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | FailureMessage Failure
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write (FailureMessage failure) = writeMessage "FAILURE" "failure" failure
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "FAILURE" = FailureMessage <$> readProp "failure" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o


add apply = ap law

add apply = ap law

module Control.Monad
  ( class Monad
  , liftM1
  , ap
  , whenM
  , unlessM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  , module Control.Bind
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
-- | - Applicative Superclass: `apply = ap`
class (Applicative m, Bind m) <= Monad m

instance monadFn :: Monad ((->) r)
instance monadArray :: Monad Array

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftM1
-- | ```
liftM1 :: forall m a b. Monad m => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  pure (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   apply = ap
-- | ```
ap :: forall m a b. Monad m => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  pure (f' a')

-- | Perform a monadic action when a condition is true, where the conditional
-- | value is also in a monadic context.
whenM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
whenM mb m = do
  b <- mb
  when b m

-- | Perform a monadic action unless a condition is true, where the conditional
-- | value is also in a monadic context.
unlessM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
unlessM mb m =  do
  b <- mb
  unless b m

module Control.Monad
  ( class Monad
  , liftM1
  , ap
  , whenM
  , unlessM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  , module Control.Bind
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
class (Applicative m, Bind m) <= Monad m

instance monadFn :: Monad ((->) r)
instance monadArray :: Monad Array

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftM1
-- | ```
liftM1 :: forall m a b. Monad m => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  pure (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   apply = ap
-- | ```
ap :: forall m a b. Monad m => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  pure (f' a')

-- | Perform a monadic action when a condition is true, where the conditional
-- | value is also in a monadic context.
whenM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
whenM mb m = do
  b <- mb
  when b m

-- | Perform a monadic action unless a condition is true, where the conditional
-- | value is also in a monadic context.
unlessM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
unlessM mb m =  do
  b <- mb
  unless b m


reuse handleJSON between multiple endpoints

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Aff, Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(..), contains)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (Middleware(..), lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBConnection, DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv")) <$> readdir path
          pure $ fst <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)
    handleConn conn@{components: Config {dir, db}} =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> files
        Tuple (Left GET) "/api/watched" -> watched
        Tuple (Left POST) "/api/update" -> update
        Tuple (Left POST) "/api/open" -> open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          files = readFiles dir :>>= respondJSON
          handleJSON :: forall a. IsForeign a => (a -> _) -> _
          handleJSON handler = do
            body <- readBody
            case runExcept $ readJSON body of
              Right x -> do
                handler x
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          open = handleJSON \(OpenRequest or) -> do
            _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
            respondJSON "{}"
          queryDB' query params = lift' $ queryDB db query params
          update = handleJSON \(UpdateRequest ur) -> do
            _ <- if ur.watched
              then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
              else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
            watched
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(..), contains)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBConnection, DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv")) <$> readdir path
          pure $ fst <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)
    handleConn conn@{components: Config {dir, db}} =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> files
        Tuple (Left GET) "/api/watched" -> watched
        Tuple (Left POST) "/api/update" -> update
        Tuple (Left POST) "/api/open" -> open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          files = readFiles dir :>>= respondJSON
          open = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (OpenRequest or) -> do
                _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
                respondJSON "{}"
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          queryDB' query params = lift' $ queryDB db query params
          update = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (UpdateRequest ur) -> do
                _ <- if ur.watched
                  then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
                  else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
                watched
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a


illustrating the problem of Transition types

Transition is fundamentally untyped…it’s a problem…

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  erg <- d3Transition "erg"
    .. duration 750.0

  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition
      -- .. duration 750.0

  chart1 ... savedTransition erg  -- works because the transition gets type (Transition Number) from chart1

  chart2 ... savedTransition erg  -- doesn't work because this needs to be (Transition String)

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  d3Transition "erg"
    .. duration 750.0

  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition

  chart1 ... namedTransition "erg"
  chart2 ... namedTransition "erg"

  pure unit


Don't regather class names from Schema for now

The schema we output has names for all the classes,
so no need to regather.  JSON Schema in general does
have unnamed classes, so we should reintroduce
regathering, once #63 is fixed.

Original commit 742408e3d29f92e08e919008b795f89401e9a25e

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) 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.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc (Renderer)
import Doc as Doc
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

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
    , topLevelName :: String
    }

type Pipeline a = Input a -> Either Error SourceCode

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

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

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

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson { renderer, input: json, topLevelName } =
    json
    # makeTypeAndUnify topLevelName
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema { renderer, input: json, topLevelName } = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema topLevelName schema
    graph
        # Doc.runRenderer renderer
        # pure

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

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 :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment { renderer, input: jsonString, topLevelName } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: obj, topLevelName }

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) 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.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc (Renderer)
import Doc as Doc
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

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
    , topLevelName :: String
    }

type Pipeline a = Input a -> Either Error SourceCode

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

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

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

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson { renderer, input: json, topLevelName } =
    json
    # makeTypeAndUnify topLevelName
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema { renderer, input: json, topLevelName } = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema topLevelName schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

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

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 :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment { renderer, input: jsonString, topLevelName } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: obj, topLevelName }


Added Selection Sort in Purescript in Ascending Order

module SelectionSort where

import Prelude
import Data.Array (snoc, delete, index, length)
import Data.Maybe (Maybe(..))

unsortedList :: Array Int
unsortedList = [11, 25, 12, 22, 64]
--length = 5

runSelectionSort :: Array Int -> Array Int
runSelectionSort arr | arr == [] = [2]
					 | otherwise = iterateList arr [] 1 (isItEmpty (index arr 0))

returnMin :: Int -> Maybe Int -> Int
returnMin a (Just b) = min a b
returnMin _ Nothing = 1

iterateList :: Array Int -> Array Int -> Int -> Int -> Array Int
iterateList arr newArr pos minVal | pos < length(arr) = iterateList arr newArr (pos + 1) (returnMin minVal (index arr pos))
								  | otherwise = createNewArr arr newArr pos minVal

createNewArr :: Array Int -> Array Int -> Int -> Int -> Array Int
createNewArr arr newArr pos minVal | length(arr) > 0 = iterateList (delete minVal arr) (snoc newArr minVal) 1 (isItEmpty (index (delete minVal arr) 0))
								   | otherwise = newArr

isItEmpty :: Maybe Int -> Int
isItEmpty (Just val) = val
isItEmpty Nothing = 0

module SelectionSort where

import Prelude
import Data.Array (cons, delete, index, length)
import Data.Maybe (Maybe(..))

unsortedList :: Array Int
unsortedList = [11, 25, 12, 22, 64]
--length = 5

runSelectionSort :: Array Int -> Array Int
runSelectionSort arr | arr == [] = [2]
					 | otherwise = iterateList arr [] 1 (isItEmpty (index arr 0))

returnMin :: Int -> Maybe Int -> Int
returnMin a (Just b) = min a b
returnMin _ Nothing = 1

iterateList :: Array Int -> Array Int -> Int -> Int -> Array Int
iterateList arr newArr pos minVal | pos < length(arr) = iterateList arr newArr (pos + 1) (returnMin minVal (index arr pos))
								  | otherwise = createNewArr arr newArr pos minVal

createNewArr :: Array Int -> Array Int -> Int -> Int -> Array Int
createNewArr arr newArr pos minVal | length(arr) > 0 = iterateList (delete minVal arr) (cons minVal newArr) 1 (isItEmpty (index (delete minVal arr) 0))
								   --| (length(arr) == 1 = (cons minVal newArr)
								   | otherwise = newArr

isItEmpty :: Maybe Int -> Int
isItEmpty (Just val) = val
isItEmpty Nothing = 0


initial new presentation api tests

initial new presentation api tests

module Model.Presentation.Test (tests) where

import Prelude (Unit, not, ($), id, map, const, discard, (<<<))
import Data.List (List(..), (!!), length)
import Data.Either (Either, either, fromRight)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Partial.Unsafe (unsafePartial)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)
import Test.Unit.Console (TESTOUTPUT)

import Model.Presentation(initial, create, presentable, size, slide, next, previous, reset)
import Model.Presentation.New as P

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Model.NewPresentation" do
      test "size" do
        let actual = testPres ^. P.size
        let expected = length testSlides
        equal expected actual
      test "slide content" do
        let actual = testPres ^. P.slide .. P.content
        let expected = testSlide 0
        equal expected actual
      test "get slide number" do
        let actual = testPres ^. P.slide .. P.number
        equal 1 actual
    suite "Model.Presentation" do
      test "initial presentation is not presentable" do
        assert "should be not presentable" $ not $ presentable $ initial
      test "create" do
        let pres = create testSource
        let actual = size pres
        let expected = 3
        equal expected actual
      test "get slide not presentable" do
        assert "no slide" $ not $ isJust (slide initial)
      test "get presentable slide" do
        let s = slide $ create testSource
        let actualContent = map _.content s
        let actualNumber = map _.number s
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "next not presentable" do
        assert "not presentable" $ not $ presentable $ next initial
      test "previous not presentable" do
        assert "not presentable" $ not $ presentable $ previous initial
      test "reset not presentable" do
        assert "not presentable" $ not $ presentable $ reset initial
      test "next presentable" do
        let pres = create testSource
        let actual = slide $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "previous presentable" do
        let pres = create testSource
        let actual = slide $ previous $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "reset presentable" do
        let pres = create testSource
        let actual = slide $ reset $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "lower clamp presentable" do
        let pres = create testSource
        let actual = slide $ previous pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "upper clamp presentable" do
        let pres = create testSource
        let actual = slide $ next $ next $ next $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 2) actualContent
        equal (Just 3) actualNumber

testSlides :: List SlamDown
testSlides = unsafePartial fromRight $ map slides $ parseMd testSource

testSlide :: Int -> SlamDown
testSlide i = unsafePartial fromJust $ testSlides !! i

testPres :: P.Presentation
testPres = unsafePartial $ fromRight $ P.create testSource

testSource :: String
testSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

module Model.Presentation.Test (tests) where

import Prelude (Unit, not, ($), id, map, const, discard)
import Data.List (List(..), (!!))
import Data.Either (either)
import Data.Maybe (Maybe(..), isJust)
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)
import Test.Unit.Console (TESTOUTPUT)

import Model.Presentation(initial, create, presentable, size, slide, next, previous, reset)

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Model.Presentation" do
      test "initial presentation is not presentable" do
        assert "should be not presentable" $ not $ presentable $ initial
      test "create" do
        let pres = create testSource
        let actual = size pres
        let expected = 3
        equal expected actual
      test "get slide not presentable" do
        assert "no slide" $ not $ isJust (slide initial)
      test "get presentable slide" do
        let s = slide $ create testSource
        let actualContent = map _.content s
        let actualNumber = map _.number s
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "next not presentable" do
        assert "not presentable" $ not $ presentable $ next initial
      test "previous not presentable" do
        assert "not presentable" $ not $ presentable $ previous initial
      test "reset not presentable" do
        assert "not presentable" $ not $ presentable $ reset initial
      test "next presentable" do
        let pres = create testSource
        let actual = slide $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "previous presentable" do
        let pres = create testSource
        let actual = slide $ previous $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "reset presentable" do
        let pres = create testSource
        let actual = slide $ reset $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "lower clamp presentable" do
        let pres = create testSource
        let actual = slide $ previous pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "upper clamp presentable" do
        let pres = create testSource
        let actual = slide $ next $ next $ next $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 2) actualContent
        equal (Just 3) actualNumber

testSlides :: List SlamDown
testSlides = either (const Nil) id $ map slides $ parseMd testSource

testSource :: String
testSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""


Make vue return Vue :: *

Make vue return Vue :: *

module Main where

import Control.Monad.Eff

main = vue
    {
        el: "#demo",
        dat: { message: "Hello Vue.js!" }
    }

foreign import data Vue :: *

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        return new Vue(opt);\
    \    }\
    \}" :: forall e r s. { el :: String | r } -> Eff e Vue

module Main where

import Control.Monad.Eff

main = vue
    {
        el: "#demo",
        dat: { message: "Hello Vue.js!" }
    }

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        new Vue(opt);\
    \    }\
    \}" :: forall e r. { el :: String | r } -> Eff e {}


Track user input

Track user input

module Main where

import CSS.Color (red, green, yellow, blue)
import Control.Monad.Aff.Console (CONSOLE, logShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..), snoc)
import Data.Maybe (Maybe(..))
import Data.Styles (buttonStyled)
import Prelude hiding (div)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event = Start | NewSequence (List String) | UserClick String | Strict DOMEvent | Click

type AppEffects = (random :: RANDOM, console :: CONSOLE)

type State =
  { sequence :: List String
  , userInput :: List String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , count : 0
  , strict: false
  }

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  { state: state
  , effects: [ do
    result <- liftEff generateSequence
    let colors = convertToColors result
    pure $ Just $ NewSequence colors
    ]
  }
foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [ logShow list *> pure Nothing ]
  }
foldp (UserClick color) state =
  { state: state { userInput = snoc state.userInput color }
  , effects: [ logShow (snoc state.userInput color) *> pure Nothing ]
  }
foldp (Strict e) state = noEffects $ state { strict = not state.strict }
foldp Click state = onlyEffects state [ log "click" *> pure Nothing ]

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled red
        #! onClick (const $ UserClick "red")
        $ text "red"
      div
        ! buttonStyled green
        #! onClick (const $ UserClick "green")
        $ text "green"
      div
        ! buttonStyled yellow
        #! onClick (const $ UserClick "yellow")
        $ text "yellow"
      div
        ! buttonStyled blue
        #! onClick (const $ UserClick "blue")
        $ text "blue"
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"
    button #! onClick (const Click) $ text "Click"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

module Main where

import CSS.Color (red, green, yellow, blue)
import Control.Monad.Aff.Console (CONSOLE, logShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..))
import Data.Maybe (Maybe(..))
import Data.Styles (buttonStyled)
import Prelude hiding (div)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event = Start | NewSequence (List String) | UserClick String | Strict DOMEvent | Click

type AppEffects = (random :: RANDOM, console :: CONSOLE)

type State =
  { sequence :: List String
  , userInput :: List String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , count : 0
  , strict: false
  }

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  { state: state
  , effects: [ do
    result <- liftEff generateSequence
    let colors = convertToColors result
    pure $ Just $ NewSequence colors
    ]
  }
foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [ logShow list *> pure Nothing ]
  }
foldp (UserClick color) state =
  onlyEffects state [ log color *> pure Nothing ]
foldp (Strict e) state = noEffects $ state { strict = not state.strict }
foldp Click state = onlyEffects state [ log "click" *> pure Nothing ]

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled red
        #! onClick (const $ UserClick "red")
        $ text "red"
      div
        ! buttonStyled green
        #! onClick (const $ UserClick "green")
        $ text "green"
      div
        ! buttonStyled yellow
        #! onClick (const $ UserClick "yellow")
        $ text "yellow"
      div
        ! buttonStyled blue
        #! onClick (const $ UserClick "blue")
        $ text "blue"
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"
    button #! onClick (const Click) $ text "Click"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input


Removed Main.purs

Removed Main.purs

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  log "Hello sailor!"


Console.logShow instead of print in example

-- | This module defines an effect, actions and handlers for working
-- | with JavaScript exceptions.

module Effect.Exception
  ( Error
  , error
  , message
  , name
  , stack
  , throwException
  , catchException
  , throw
  , try
  ) where

import Prelude

import Effect (Effect)

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))

-- | The type of JavaScript errors
foreign import data Error :: Type

instance showError :: Show Error where
  show = showErrorImpl

foreign import showErrorImpl :: Error -> String

-- | Create a JavaScript error, specifying a message
foreign import error :: String -> Error

-- | Get the error message from a JavaScript error
foreign import message :: Error -> String

-- | Get the error name when defined, or fallback to 'Error'
foreign import name :: Error -> String

-- | Get the stack trace from a JavaScript error
stack :: Error -> Maybe String
stack = stackImpl Just Nothing

foreign import stackImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Error
  -> Maybe String

-- | Throw an exception
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = do
-- |   x <- readNumber
-- |   when (x < 0) $ throwException $
-- |     error "Expected a non-negative number"
-- | ```
foreign import throwException
  :: forall a
   . Error
  -> Effect a

-- | Catch an exception by providing an exception handler.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = catchException Console.logShow do
-- |   Console.log "Exceptions thrown in this block will be logged to the console"
-- | ```
foreign import catchException
  :: forall a
   . (Error -> Effect a)
  -> Effect a
  -> Effect a

-- | A shortcut allowing you to throw an error in one step. Defined as
-- | `throwException <<< error`.
throw :: forall a. String -> Effect a
throw = throwException <<< error

-- | Runs an Eff and returns eventual Exceptions as a `Left` value. If the
-- | computation succeeds the result gets wrapped in a `Right`.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main :: forall eff. Effect Unit
-- | main = do
-- |   result <- try (readTextFile UTF8 "README.md")
-- |   case result of
-- |     Right lines ->
-- |       Console.log ("README: \n" <> lines )
-- |     Left error ->
-- |       Console.error ("Couldn't open README.md. Error was: " <> show error)
-- | ```

try :: forall a. Effect a -> Effect (Either Error a)
try action = catchException (pure <<< Left) (Right <$> action)

-- | This module defines an effect, actions and handlers for working
-- | with JavaScript exceptions.

module Effect.Exception
  ( Error
  , error
  , message
  , name
  , stack
  , throwException
  , catchException
  , throw
  , try
  ) where

import Prelude

import Effect (Effect)

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))

-- | The type of JavaScript errors
foreign import data Error :: Type

instance showError :: Show Error where
  show = showErrorImpl

foreign import showErrorImpl :: Error -> String

-- | Create a JavaScript error, specifying a message
foreign import error :: String -> Error

-- | Get the error message from a JavaScript error
foreign import message :: Error -> String

-- | Get the error name when defined, or fallback to 'Error'
foreign import name :: Error -> String

-- | Get the stack trace from a JavaScript error
stack :: Error -> Maybe String
stack = stackImpl Just Nothing

foreign import stackImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Error
  -> Maybe String

-- | Throw an exception
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = do
-- |   x <- readNumber
-- |   when (x < 0) $ throwException $
-- |     error "Expected a non-negative number"
-- | ```
foreign import throwException
  :: forall a
   . Error
  -> Effect a

-- | Catch an exception by providing an exception handler.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = catchException print do
-- |   Console.log "Exceptions thrown in this block will be logged to the console"
-- | ```
foreign import catchException
  :: forall a
   . (Error -> Effect a)
  -> Effect a
  -> Effect a

-- | A shortcut allowing you to throw an error in one step. Defined as
-- | `throwException <<< error`.
throw :: forall a. String -> Effect a
throw = throwException <<< error

-- | Runs an Eff and returns eventual Exceptions as a `Left` value. If the
-- | computation succeeds the result gets wrapped in a `Right`.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main :: forall eff. Effect Unit
-- | main = do
-- |   result <- try (readTextFile UTF8 "README.md")
-- |   case result of
-- |     Right lines ->
-- |       Console.log ("README: \n" <> lines )
-- |     Left error ->
-- |       Console.error ("Couldn't open README.md. Error was: " <> show error)
-- | ```

try :: forall a. Effect a -> Effect (Either Error a)
try action = catchException (pure <<< Left) (Right <$> action)


Add hoistMiddleware

Add hoistMiddleware

module Hyper.Middleware where

import Prelude
import Control.IxMonad (class IxMonad, ibind, ipure)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Data.Tuple (Tuple(..), snd)
import Hyper.Middleware.Class (class IxMonadMiddleware)

newtype Middleware m i o a = Middleware (i → m (Tuple a o))

runMiddleware ∷ ∀ m i o a. Middleware m i o a → i → m (Tuple a o)
runMiddleware (Middleware m) x = m x

evalMiddleware ∷ ∀ m i o a. Functor m ⇒ Middleware m i o a → i → m o
evalMiddleware a s = map snd (runMiddleware a s)

hoistMiddleware ∷ ∀ f g i o a. (f ~> g) → Middleware f i o a → Middleware g i o a
hoistMiddleware f (Middleware k) = Middleware (f <<< k)

instance ixMonadMiddlewareMiddleware ∷ Applicative m ⇒ IxMonadMiddleware (Middleware m) where
  getConn = Middleware $ \c → pure (Tuple c c)
  putConn c = Middleware $ \_ → pure (Tuple unit c)

instance ixMonadMiddleware ∷ Monad m ⇒ IxMonad (Middleware m) where
  ipure x = Middleware $ \s → pure (Tuple x s)
  ibind (Middleware ma) f =
    Middleware $ \s →
      ma s >>= \(Tuple x s') →
      case f x of
        Middleware a → a s'

{-
instance monadEffMiddleware ∷ MonadEff e m ⇒ IxMonadEff e (Middleware m) where
  iliftEff e = Middleware $ \s → do
    x ← liftEff (runIxEff e)
    pure (Tuple x s)
-}

instance functorMiddleware ∷ Monad m => Functor (Middleware m i i) where
  map f a =
    Middleware $ \s →
      runMiddleware a s >>= \(Tuple a' s') →
      pure (Tuple (f a') s')

instance applyMiddleware ∷ Monad m => Apply (Middleware m i i) where
  apply f a =
    Middleware $ \s →
      runMiddleware f s >>= \(Tuple f' s') →
      runMiddleware a s' >>= \(Tuple a' s'') →
      pure (Tuple (f' a') s'')

instance applicativeMiddleware ∷ Monad m => Applicative (Middleware m i i) where
  pure = ipure

instance bindMiddleware ∷ Monad m ⇒ Bind (Middleware m i i) where
  bind = ibind

instance monadMiddleware ∷ (Monad m, Applicative m) => Monad (Middleware m i i)

instance monadEffMiddleware ∷ MonadEff e m ⇒ MonadEff e (Middleware m i i) where
  liftEff e = Middleware $ \s → do
    x ← liftEff e
    pure (Tuple x s)

-- TODO: Can this be written as an instance of MonadTrans? Can't get the type
-- arguments to line up properly...
lift' ∷ ∀ m i a. Monad m ⇒ m a → Middleware m i i a
lift' a = Middleware $ \s → do
  x ← a
  pure (Tuple x s)

module Hyper.Middleware where

import Prelude
import Control.IxMonad (class IxMonad, ibind, ipure)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Data.Tuple (Tuple(..), snd)
import Hyper.Middleware.Class (class IxMonadMiddleware)

newtype Middleware m i o a = Middleware (i → m (Tuple a o))

runMiddleware ∷ ∀ m i o a. Middleware m i o a → i → m (Tuple a o)
runMiddleware (Middleware m) x = m x

evalMiddleware ∷ ∀ m i o a. Functor m ⇒ Middleware m i o a → i → m o
evalMiddleware a s = map snd (runMiddleware a s)

instance ixMonadMiddlewareMiddleware ∷ Applicative m ⇒ IxMonadMiddleware (Middleware m) where
  getConn = Middleware $ \c → pure (Tuple c c)
  putConn c = Middleware $ \_ → pure (Tuple unit c)

instance ixMonadMiddleware ∷ Monad m ⇒ IxMonad (Middleware m) where
  ipure x = Middleware $ \s → pure (Tuple x s)
  ibind (Middleware ma) f =
    Middleware $ \s →
      ma s >>= \(Tuple x s') →
      case f x of
        Middleware a → a s'

{-
instance monadEffMiddleware ∷ MonadEff e m ⇒ IxMonadEff e (Middleware m) where
  iliftEff e = Middleware $ \s → do
    x ← liftEff (runIxEff e)
    pure (Tuple x s)
-}

instance functorMiddleware ∷ Monad m => Functor (Middleware m i i) where
  map f a =
    Middleware $ \s →
      runMiddleware a s >>= \(Tuple a' s') →
      pure (Tuple (f a') s')

instance applyMiddleware ∷ Monad m => Apply (Middleware m i i) where
  apply f a =
    Middleware $ \s →
      runMiddleware f s >>= \(Tuple f' s') →
      runMiddleware a s' >>= \(Tuple a' s'') →
      pure (Tuple (f' a') s'')

instance applicativeMiddleware ∷ Monad m => Applicative (Middleware m i i) where
  pure = ipure

instance bindMiddleware ∷ Monad m ⇒ Bind (Middleware m i i) where
  bind = ibind

instance monadMiddleware ∷ (Monad m, Applicative m) => Monad (Middleware m i i)

instance monadEffMiddleware ∷ MonadEff e m ⇒ MonadEff e (Middleware m i i) where
  liftEff e = Middleware $ \s → do
    x ← liftEff e
    pure (Tuple x s)

-- TODO: Can this be written as an instance of MonadTrans? Can't get the type
-- arguments to line up properly...
lift' ∷ ∀ m i a. Monad m ⇒ m a → Middleware m i i a
lift' a = Middleware $ \s → do
  x ← a
  pure (Tuple x s)


randomInt is inclusive

randomInt is inclusive

{-
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 Data.UUID.Random
  ( UUIDv4
  , make
  , toString
  , fromString
  ) where

import Prelude
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Random as Random
import Control.MonadZero (guard)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Int as Int
import Data.Traversable (sequence, traverse)
import Data.Maybe (Maybe(..), fromJust)
import Data.String as String
import Partial.Unsafe (unsafePartial)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data UUIDv4 = UUIDv4 String (Array Int)

make ∷ ∀ m eff. MonadEff (random ∷ Random.RANDOM | eff) m ⇒ m UUIDv4
make = liftEff $ make' Random.randomInt

make' ∷ ∀ f. Applicative f ⇒ (Int → Int → f Int) → f UUIDv4
make' rand = unsafeToUUIDv4 <$> sequence uuid
  where
    uuid = x8 <> x4 <> [ pure 4 ] <> x3 <> y <> x3 <> x12
    y = [ rand 8 11 ]
    x = [ rand 0 15 ]
    x3 = x <> x <> x
    x4 = x3 <> x
    x8 = x4 <> x4
    x12 = x8 <> x4

toString ∷ UUIDv4 → String
toString (UUIDv4 s _) = s

toString' ∷ Array Int → String
toString' is =
  String.joinWith "-"
    [ print 0 8
    , print 8 12
    , print 12 16
    , print 16 20
    , print 20 32
    ]
  where
    print i j =
      Array.slice i j is
        # map (Int.toStringAs hexRadix)
        # String.joinWith ""

fromString ∷ String → Maybe UUIDv4
fromString str = do
  let
    ds = String.split (String.Pattern "") =<< String.split (String.Pattern "-") str
  is ← traverse (Int.fromStringAs hexRadix) ds
  rd ← Array.index is 12
  yd ← Array.index is 16
  guard $ Array.length is == 32
  guard $ rd == 4
  guard $ yd >= 8 && yd < 12
  pure (unsafeToUUIDv4 is)

unsafeToUUIDv4 ∷ Array Int → UUIDv4
unsafeToUUIDv4 is = UUIDv4 (toString' is) is

hexRadix ∷ Int.Radix
hexRadix = unsafePartial (fromJust (Int.radix 16))

instance eqUUIDv4 ∷ Eq UUIDv4 where
  eq (UUIDv4 s1 _) (UUIDv4 s2 _) = s1 == s2

instance ordUUIDv4 ∷ Ord UUIDv4 where
  compare (UUIDv4 s1 _) (UUIDv4 s2 _) = compare s1 s2

instance showUUIDv4 ∷ Show UUIDv4 where
  show (UUIDv4 s1 _) = "UUIDv4 " <> show s1

instance arbitraryUUIDv4 ∷ SC.Arbitrary UUIDv4 where
  arbitrary =
    make' Gen.chooseInt

instance encodeJson ∷ EncodeJson UUIDv4 where
  encodeJson (UUIDv4 s _) = encodeJson s

instance decodeJson ∷ DecodeJson UUIDv4 where
  decodeJson json = do
    s ← decodeJson json
    case fromString s of
      Just u  → Right u
      Nothing → Left ("Invalid UUIDv4: " <> s)

{-
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 Data.UUID.Random
  ( UUIDv4
  , make
  , toString
  , fromString
  ) where

import Prelude
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Random as Random
import Control.MonadZero (guard)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Int as Int
import Data.Traversable (sequence, traverse)
import Data.Maybe (Maybe(..), fromJust)
import Data.String as String
import Partial.Unsafe (unsafePartial)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data UUIDv4 = UUIDv4 String (Array Int)

make ∷ ∀ m eff. MonadEff (random ∷ Random.RANDOM | eff) m ⇒ m UUIDv4
make = liftEff $ make' Random.randomInt

make' ∷ ∀ f. Applicative f ⇒ (Int → Int → f Int) → f UUIDv4
make' rand = unsafeToUUIDv4 <$> sequence uuid
  where
    uuid = x8 <> x4 <> [ pure 4 ] <> x3 <> y <> x3 <> x12
    y = [ rand 8 12 ]
    x = [ rand 0 16 ]
    x3 = x <> x <> x
    x4 = x3 <> x
    x8 = x4 <> x4
    x12 = x8 <> x4

toString ∷ UUIDv4 → String
toString (UUIDv4 s _) = s

toString' ∷ Array Int → String
toString' is =
  String.joinWith "-"
    [ print 0 8
    , print 8 12
    , print 12 16
    , print 16 20
    , print 20 32
    ]
  where
    print i j =
      Array.slice i j is
        # map (Int.toStringAs hexRadix)
        # String.joinWith ""

fromString ∷ String → Maybe UUIDv4
fromString str = do
  let
    ds = String.split (String.Pattern "") =<< String.split (String.Pattern "-") str
  is ← traverse (Int.fromStringAs hexRadix) ds
  rd ← Array.index is 12
  yd ← Array.index is 16
  guard $ Array.length is == 32
  guard $ rd == 4
  guard $ yd >= 8 && yd < 12
  pure (unsafeToUUIDv4 is)

unsafeToUUIDv4 ∷ Array Int → UUIDv4
unsafeToUUIDv4 is = UUIDv4 (toString' is) is

hexRadix ∷ Int.Radix
hexRadix = unsafePartial (fromJust (Int.radix 16))

instance eqUUIDv4 ∷ Eq UUIDv4 where
  eq (UUIDv4 s1 _) (UUIDv4 s2 _) = s1 == s2

instance ordUUIDv4 ∷ Ord UUIDv4 where
  compare (UUIDv4 s1 _) (UUIDv4 s2 _) = compare s1 s2

instance showUUIDv4 ∷ Show UUIDv4 where
  show (UUIDv4 s1 _) = "UUIDv4 " <> show s1

instance arbitraryUUIDv4 ∷ SC.Arbitrary UUIDv4 where
  -- chooseInt is inclusive, randomInt is exclusive
  arbitrary =
    make' \i j → Gen.chooseInt i (i - 1)

instance encodeJson ∷ EncodeJson UUIDv4 where
  encodeJson (UUIDv4 s _) = encodeJson s

instance decodeJson ∷ DecodeJson UUIDv4 where
  decodeJson json = do
    s ← decodeJson json
    case fromString s of
      Just u  → Right u
      Nothing → Left ("Invalid UUIDv4: " <> s)


Parse the JSON

Parse the JSON

module Component.Article where

import Prelude
import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E
import qualified Halogen.HTML.Properties.Indexed as P
import Control.Monad.Aff (Aff())
import Data.Either (Either(..))
import Network.HTTP.Affjax (AJAX())
import qualified Network.HTTP.Affjax as Ajax

import Data.Foreign
import Data.Foreign.Class

import Model

type State = Article

data Query a = Toggle a
             | Load Int a

type ArticleEffects eff = HalogenEffects (ajax :: AJAX | eff)
data ArticleContents = ArticleContents {title :: String, contents :: String}

article :: forall eff. Component State Query (Aff (ArticleEffects eff))
article = component render eval
  where

  render :: State -> ComponentHTML Query
  render state =
    let title = H.h2 [E.onClick (E.input_ Toggle)
                     , P.initializer \_ -> action (Load state.id)]
                [H.text state.title] in
    H.div_
      if state.visible
      then
        [ title
        , H.text state.contents
        ]
      else
         [title]

  eval ::  Natural Query (ComponentDSL State Query (Aff (ArticleEffects eff)))
  eval (Toggle next) = do
    modify (\s -> s {visible = not s.visible})
    pure next
  eval (Load id next) = do
    c <- liftAff' $ getBlog id
    modify (\s -> s {contents = c.contents, title = c.title})
    pure next

getBlog :: forall eff. Int -> Aff (ajax :: AJAX | eff) {title :: String, contents :: String}
getBlog id =
  let url = "api/blog/" ++ show id in
  do
    res <- Ajax.get url
    return case (do
      title <- readProp "title" res.response
      contents <- readProp "content" res.response
      return {title : title, contents: contents}) of
             Right c -> c
             Left _ -> {title : "", contents : ""}

module Component.Article where

import Prelude
import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E
import qualified Halogen.HTML.Properties.Indexed as P
import Control.Monad.Aff (Aff())

import Network.HTTP.Affjax (AJAX())
import qualified Network.HTTP.Affjax as Ajax

import Model

type State = Article

data Query a = Toggle a
             | Load Int a

type ArticleEffects eff = HalogenEffects (ajax :: AJAX | eff)

article :: forall eff. Component State Query (Aff (ArticleEffects eff))
article = component render eval
  where

  render :: State -> ComponentHTML Query
  render state =
    let title = H.h2 [E.onClick (E.input_ Toggle)
                     , P.initializer \_ -> action (Load state.id)]
                [H.text state.title] in
    H.div_
      if state.visible
      then
        [ title
        , H.text state.contents
        ]
      else
         [title]

  eval ::  Natural Query (ComponentDSL State Query (Aff (ArticleEffects eff)))
  eval (Toggle next) = do
    modify (\s -> s {visible = not s.visible})
    pure next
  eval (Load id next) = do
    c <- liftAff' $ getBlog id
    modify (\s -> s {contents = c})
    pure next

getBlog :: forall eff. Int -> Aff (ajax :: AJAX | eff) String
getBlog id =
  let url = "api/blog/" ++ show id in
  do
    res <- Ajax.get url
    return res.response


Expand docs

Expand docs

-- | This module provides a way of dealing with the JS idiom of options
-- | objects in PureScript, by giving you the tools to provide a reasonably
-- | comfortable typed layer on top of JavaScript APIs which make use of this
-- | idiom.
-- |
-- | Many JavaScript APIs include functions which take an object argument,
-- | where the object's properties come from a fixed set of optional
-- | configuration values. For example, the `createWriteStream` function from
-- | the Node.js `fs` module may contain properties such as:
-- |
-- | - `flags`, which should be a `String`, such as `"w"`, `"rw"`, or `"r+"`,
-- | - `defaultEncoding`, which should be a `String` representing an
-- |   encoding, such as `"utf8"`,
-- |
-- | and so on.
-- |
-- | PureScript's record types can be a little awkward for this, since it is
-- | usually the case that any subset of these properties can be specified;
-- | however, a value of  type `{ flags :: String, defaultEncoding :: String, [...] }`
-- | must include every property listed, even if you only want to specify
-- | one or two properties.
-- |
-- | Using this module, you could wrap `fs.createWriteStream` as follows:
-- |
-- | First, create a phantom type used for the options object:
-- |
-- | ```purescript
-- | data CreateWriteStreamOptions
-- | ```
-- |
-- | Then, create `Option` values for each of the options:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions String
-- | flags = opt "flags"
-- |
-- | defaultEncoding :: Option CreateWriteStreamOptions String
-- | defaultEncoding = opt "defaultEncoding"
-- |
-- | -- and so on
-- | ```
-- |
-- | Import the function you're wrapping using the FFI, using the `Foreign`
-- | type for the options object:
-- |
-- | ```purescript
-- | -- don't export this!
-- | foreign import createWriteStreamImpl :: forall eff. FilePath -> Foreign -> Eff (fs :: FS | eff) Unit
-- | ```
-- |
-- | Finally, in the function you are going to export, take an `Options` value
-- | for the options argument, and use the `options` function provided by this
-- | library to convert it into a `Foreign` value, which will then have a
-- | suitable representation for passing to the JavaScript API.
-- |
-- | ```
-- | createWriteStream :: forall eff. FilePath -> Options CreateWriteStreamOptions -> Eff (fs :: FS | eff) Unit
-- | createWriteStream path opts = createWriteStreamImpl path (options opts)
-- | ```
-- |
-- | Then, users of your API can create `Options` values using the `:=`
-- | operator to assign values for the options they want to configure, and the
-- | `Monoid Options` instance to combine them. For example, as a user of this
-- | API, you might write:
-- |
-- | ```purescript
-- | FS.createWriteStream "file.txt" $
-- |    defaultEncoding := "utf8" <>
-- |    flags := "rw"
-- | ```
-- |
-- | You can also use more specific types for more type safety. For example,
-- | it would be safer to use the existing `FileFlags` and `Encoding` types
-- | already provided by the `node-fs` library. However, we cannot use them
-- | directly because they will have the wrong runtime representation. This is
-- | where the `Contravariant` instance for `Option` comes in; it can be used
-- | to transform an option's value to give it a suitable runtime
-- | representation based on what the JS API is expecting. For example:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions FileFlags
-- | flags = cmap fileFlagsToNode (opt "flags")
-- | ```
-- |
-- | Note that `fileFlagsToNode` takes a `FileFlags` and returns a `String`
-- | suitable for passing to a Node.js API.
module Data.Options
  ( Options(..)
  , options
  , Option
  , assoc, (:=)
  , optional
  , opt
  , tag
  , defaultToOptions
  ) where

import Prelude

import Data.Foreign (toForeign, Foreign)
import Data.Maybe (Maybe, maybe)
import Data.Monoid (mempty, class Monoid)
import Data.Newtype (class Newtype, unwrap)
import Data.Op (Op(..))
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))

-- | The `Options` type represents a set of options. The type argument is a
-- | phantom type, which is useful for ensuring that options for one particular
-- | API are not accidentally passed to some other API.
newtype Options opt = Options (Array (Tuple String Foreign))

derive instance newtypeOptions :: Newtype (Options opt) _

instance semigroupOptions :: Semigroup (Options opt) where
  append (Options xs) (Options ys) = Options (xs <> ys)

instance monoidOptions :: Monoid (Options opt) where
  mempty = Options []

-- | Convert an `Options` value into a JavaScript object, suitable for passing
-- | to JavaScript APIs.
options :: forall opt. Options opt -> Foreign
options (Options os) = toForeign (StrMap.fromFoldable os)

-- | An `Option` represents an opportunity to configure a specific attribute
-- | of a call to some API. This normally corresponds to one specific property
-- | of an "options" object in JavaScript APIs, but can in general correspond
-- | to zero or more actual properties.
type Option opt = Op (Options opt)

-- | Associates a value with a specific option.
assoc :: forall opt value. Option opt value -> value -> Options opt
assoc = unwrap

-- | An infix version of `assoc`.
infixr 6 assoc as :=

-- | A version of `assoc` which takes possibly absent values. `Nothing` values
-- | are ignored; passing `Nothing` for the second argument will result in an
-- | empty `Options`.
optional :: forall opt value. Option opt value -> Option opt (Maybe value)
optional option = Op $ maybe mempty (option := _)

-- | The default way of creating `Option` values. Constructs an `Option` with
-- | the given key, which passes the given value through unchanged.
opt :: forall opt value. String -> Option opt value
opt = Op <<< defaultToOptions

-- | Create a `tag`, by fixing an `Option` to a single value.
tag :: forall opt value. Option opt value -> value -> Option opt Unit
tag o value = Op \_ -> o := value

-- | The default method for turning a string property key into an
-- | `Option`. This function simply calls `toForeign` on the value. If
-- | you need some other behaviour, you can write your own function to replace
-- | this one, and construct an `Option` yourself.
defaultToOptions :: forall opt value. String -> value -> Options opt
defaultToOptions k v = Options [Tuple k (toForeign v)]