runServer now uses runAff instead of launchAff.

module Hyper.Node.Server
       ( HttpRequest
       , HttpResponse
       , NodeResponse
       , writeString
       , write
       , module Hyper.Node.Server.Options
       , runServer
       , runServer'
       ) where

import Prelude
import Data.HTTP.Method as Method
import Data.Int as Int
import Data.StrMap as StrMap
import Node.Buffer as Buffer
import Node.HTTP as HTTP
import Node.Stream as Stream
import Control.IxMonad (ipure, (:*>), (:>>=))
import Control.Monad.Aff (Aff, launchAff, makeAff, runAff)
import Control.Monad.Aff.AVar (putVar, takeVar, modifyVar, makeVar', AVAR, makeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException, error)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..), either)
import Data.Lazy (defer)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware, evalMiddleware, lift')
import Hyper.Middleware.Class (getConn, modifyConn)
import Hyper.Node.Server.Options as Hyper.Node.Server.Options
import Hyper.Node.Server.Options (Options)
import Hyper.Request (class ReadableBody, class Request, class StreamableBody, RequestData, parseUrl, readBody)
import Hyper.Response (class ResponseWritable, class Response, ResponseEnded, StatusLineOpen)
import Hyper.Status (Status(..))
import Node.Buffer (BUFFER, Buffer)
import Node.Encoding (Encoding(..))
import Node.HTTP (HTTP)
import Node.Stream (Stream, Writable)

data HttpRequest
  = HttpRequest HTTP.Request RequestData

instance requestHttpRequest :: Monad m => Request HttpRequest m where
  getRequestData = do
    getConn :>>=
    case _ of
      { request: HttpRequest _ d } -> ipure d

-- A limited version of Writable () e, with which you can only write, not end,
-- the Stream.
newtype NodeResponse m e
  = NodeResponse (Writable () e -> m Unit)

writeString :: forall m e. MonadAff e m => Encoding -> String -> NodeResponse m e
writeString enc str = NodeResponse $ \w -> liftAff (makeAff (writeAsAff w))
  where
    writeAsAff w fail succeed =
      Stream.writeString w enc str (succeed unit) >>=
      if _
        then succeed unit
        else fail (error "Failed to write string to response")

write :: forall m e. MonadAff e m => Buffer -> NodeResponse m e
write buffer = NodeResponse $ \w ->
  liftAff (makeAff (\fail succeed -> void $ Stream.write w buffer (succeed unit)))

instance stringNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m String where
  toResponse = ipure <<< writeString UTF8

instance stringAndEncodingNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m (Tuple String Encoding) where
  toResponse (Tuple body encoding) =
    ipure (writeString encoding body)

instance bufferNodeResponse :: (MonadAff e m)
                                  => ResponseWritable (NodeResponse m e) m Buffer where
  toResponse buf =
    ipure (write buf)

-- Helper function that reads a Stream into a Buffer, and throws error
-- in `Aff` when failed.
readBodyAsBuffer
  :: forall e.
     HttpRequest
  -> Aff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) Buffer
readBodyAsBuffer (HttpRequest request _) = do
  let stream = HTTP.requestAsStream request
  bodyResult <- makeVar
  chunks <- makeVar' []
  fillResult <- liftEff $
    catchException (pure <<< Left) (Right <$> fillBody stream chunks bodyResult)
  -- Await the body, or an error.
  body <- takeVar bodyResult
  -- Return the body, if neither `fillResult` nor `body` is a `Left`.
  either throwError pure (fillResult *> body)
  where
    fillBody stream chunks bodyResult = do
      -- Append all chunks to the body buffer.
      Stream.onData stream \chunk ->
        void (launchAff (modifyVar (_ <> [chunk]) chunks))
      -- Complete with `Left` on error.
      Stream.onError stream $
        void <<< launchAff <<< putVar bodyResult <<< Left
      -- Complete with `Right` on successful "end" event.
      Stream.onEnd stream $ void $ launchAff $
        takeVar chunks
        >>= concat'
        >>= (pure <<< Right)
        >>= putVar bodyResult
    concat' = liftEff <<< Buffer.concat

instance readableBodyHttpRequestString :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m String where
  readBody =
    readBody :>>= (liftEff <<< Buffer.toString UTF8)

instance readableBodyHttpRequestBuffer :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m Buffer where
  readBody =
    _.request <$> getConn :>>=
    case _ of
      r -> liftAff (readBodyAsBuffer r)

instance streamableBodyHttpRequestReadable :: MonadAff (http :: HTTP | e) m
                                           => StreamableBody
                                              HttpRequest
                                              m
                                              (Stream (read :: Stream.Read) (http :: HTTP, exception :: EXCEPTION | e)) where
  streamBody =
    _.request <$> getConn :>>=
    case _ of
      HttpRequest request _ -> ipure (HTTP.requestAsStream request)

-- TODO: Make a newtype
data HttpResponse state = HttpResponse HTTP.Response

getWriter ∷ ∀ req res c m rw.
            Monad m ⇒
            Middleware
            m
            (Conn req { writer ∷ rw | res } c)
            (Conn req { writer ∷ rw | res } c)
            rw
getWriter = _.response.writer <$> getConn

setStatus ∷ ∀ req res c m e.
            MonadEff (http ∷ HTTP | e) m
          ⇒ Status
          → HTTP.Response
          → Middleware m (Conn req res c) (Conn req res c) Unit
setStatus (Status { code, reasonPhrase }) r = liftEff do
  HTTP.setStatusCode r code
  HTTP.setStatusMessage r reasonPhrase

writeHeader' ∷ ∀ req res c m e.
               MonadEff (http ∷ HTTP | e) m
             ⇒ (Tuple String String)
             → HTTP.Response
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeHeader' (Tuple name value) r =
  liftEff $ HTTP.setHeader r name value

writeResponse ∷ ∀ req res c m e.
                MonadAff (http ∷ HTTP | e) m
             ⇒ HTTP.Response
             → NodeResponse m (http :: HTTP | e)
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeResponse r (NodeResponse f) =
  lift' (f (HTTP.responseAsStream r))

endResponse ∷ ∀ req res c m e.
              MonadEff (http ∷ HTTP | e) m
            ⇒ HTTP.Response
            → Middleware m (Conn req res c) (Conn req res c) Unit
endResponse r =
  liftEff (Stream.end (HTTP.responseAsStream r) (pure unit))

instance responseWriterHttpResponse :: MonadAff (http ∷ HTTP | e) m
                                    => Response HttpResponse m (NodeResponse m (http :: HTTP | e)) where
  writeStatus status =
    getConn :>>= \{ response: HttpResponse r } ->
      setStatus status r
      :*> modifyConn (_ { response = HttpResponse r })

  writeHeader header =
    getConn :>>= \{ response: HttpResponse r } ->
      writeHeader' header r
      :*> modifyConn (_ { response = HttpResponse r })

  closeHeaders =
    getConn :>>= \{ response: HttpResponse r } ->
      modifyConn (_ { response = HttpResponse r })

  send f =
    getConn :>>= \{ response: HttpResponse r } ->
      writeResponse r f
      :*> modifyConn (_ { response = HttpResponse r })

  end =
    getConn :>>= \{ response: HttpResponse r } ->
      endResponse r
      :*> modifyConn (_ { response = HttpResponse r })

mkHttpRequest :: HTTP.Request -> HttpRequest
mkHttpRequest request =
  HttpRequest request requestData
  where
    headers = HTTP.requestHeaders request
    requestData =
      { url: HTTP.requestURL request
      , parsedUrl: defer \_ -> parseUrl (HTTP.requestURL request)
      , headers: headers
      , method: Method.fromString (HTTP.requestMethod request)
      , contentLength: StrMap.lookup "content-length" headers
                      >>= Int.fromString
      }

runServer'
  :: forall m e c c'
   . Functor m
  => Options e
  -> c
  -> (forall a. m a -> Aff (http :: HTTP | e) a)
  -> Middleware
     m
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer' options components runM middleware = do
  server <- HTTP.createServer onRequest
  let listenOptions = { port: unwrap options.port
                      , hostname: unwrap options.hostname
                      , backlog: Nothing
                      }
  HTTP.listen server listenOptions (options.onListening options.hostname options.port)
  where
    onRequest ∷ HTTP.Request → HTTP.Response → Eff (http :: HTTP | e) Unit
    onRequest request response =
      let conn = { request: mkHttpRequest request
                 , response: HttpResponse response
                 , components: components
                 }
      in conn # evalMiddleware middleware # runM # runAff options.onRequestError (const $ pure unit) # void

runServer
  :: forall e c c'.
     Options e
  -> c
  -> Middleware
     (Aff (http :: HTTP | e))
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer options components middleware =
  runServer' options components id middleware

module Hyper.Node.Server
       ( HttpRequest
       , HttpResponse
       , NodeResponse
       , writeString
       , write
       , module Hyper.Node.Server.Options
       , runServer
       , runServer'
       ) where

import Prelude
import Data.HTTP.Method as Method
import Data.Int as Int
import Data.StrMap as StrMap
import Node.Buffer as Buffer
import Node.HTTP as HTTP
import Node.Stream as Stream
import Control.IxMonad (ipure, (:*>), (:>>=))
import Control.Monad.Aff (Aff, launchAff, makeAff)
import Control.Monad.Aff.AVar (putVar, takeVar, modifyVar, makeVar', AVAR, makeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException, error)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..), either)
import Data.Lazy (defer)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware, evalMiddleware, lift')
import Hyper.Middleware.Class (getConn, modifyConn)
import Hyper.Node.Server.Options as Hyper.Node.Server.Options
import Hyper.Node.Server.Options (Options)
import Hyper.Request (class ReadableBody, class Request, class StreamableBody, RequestData, parseUrl, readBody)
import Hyper.Response (class ResponseWritable, class Response, ResponseEnded, StatusLineOpen)
import Hyper.Status (Status(..))
import Node.Buffer (BUFFER, Buffer)
import Node.Encoding (Encoding(..))
import Node.HTTP (HTTP)
import Node.Stream (Stream, Writable)

data HttpRequest
  = HttpRequest HTTP.Request RequestData

instance requestHttpRequest :: Monad m => Request HttpRequest m where
  getRequestData = do
    getConn :>>=
    case _ of
      { request: HttpRequest _ d } -> ipure d

-- A limited version of Writable () e, with which you can only write, not end,
-- the Stream.
newtype NodeResponse m e
  = NodeResponse (Writable () e -> m Unit)

writeString :: forall m e. MonadAff e m => Encoding -> String -> NodeResponse m e
writeString enc str = NodeResponse $ \w -> liftAff (makeAff (writeAsAff w))
  where
    writeAsAff w fail succeed =
      Stream.writeString w enc str (succeed unit) >>=
      if _
        then succeed unit
        else fail (error "Failed to write string to response")

write :: forall m e. MonadAff e m => Buffer -> NodeResponse m e
write buffer = NodeResponse $ \w ->
  liftAff (makeAff (\fail succeed -> void $ Stream.write w buffer (succeed unit)))

instance stringNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m String where
  toResponse = ipure <<< writeString UTF8

instance stringAndEncodingNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m (Tuple String Encoding) where
  toResponse (Tuple body encoding) =
    ipure (writeString encoding body)

instance bufferNodeResponse :: (MonadAff e m)
                                  => ResponseWritable (NodeResponse m e) m Buffer where
  toResponse buf =
    ipure (write buf)

-- Helper function that reads a Stream into a Buffer, and throws error
-- in `Aff` when failed.
readBodyAsBuffer
  :: forall e.
     HttpRequest
  -> Aff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) Buffer
readBodyAsBuffer (HttpRequest request _) = do
  let stream = HTTP.requestAsStream request
  bodyResult <- makeVar
  chunks <- makeVar' []
  fillResult <- liftEff $
    catchException (pure <<< Left) (Right <$> fillBody stream chunks bodyResult)
  -- Await the body, or an error.
  body <- takeVar bodyResult
  -- Return the body, if neither `fillResult` nor `body` is a `Left`.
  either throwError pure (fillResult *> body)
  where
    fillBody stream chunks bodyResult = do
      -- Append all chunks to the body buffer.
      Stream.onData stream \chunk ->
        void (launchAff (modifyVar (_ <> [chunk]) chunks))
      -- Complete with `Left` on error.
      Stream.onError stream $
        void <<< launchAff <<< putVar bodyResult <<< Left
      -- Complete with `Right` on successful "end" event.
      Stream.onEnd stream $ void $ launchAff $
        takeVar chunks
        >>= concat'
        >>= (pure <<< Right)
        >>= putVar bodyResult
    concat' = liftEff <<< Buffer.concat

instance readableBodyHttpRequestString :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m String where
  readBody =
    readBody :>>= (liftEff <<< Buffer.toString UTF8)

instance readableBodyHttpRequestBuffer :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m Buffer where
  readBody =
    _.request <$> getConn :>>=
    case _ of
      r -> liftAff (readBodyAsBuffer r)

instance streamableBodyHttpRequestReadable :: MonadAff (http :: HTTP | e) m
                                           => StreamableBody
                                              HttpRequest
                                              m
                                              (Stream (read :: Stream.Read) (http :: HTTP, exception :: EXCEPTION | e)) where
  streamBody =
    _.request <$> getConn :>>=
    case _ of
      HttpRequest request _ -> ipure (HTTP.requestAsStream request)

-- TODO: Make a newtype
data HttpResponse state = HttpResponse HTTP.Response

getWriter ∷ ∀ req res c m rw.
            Monad m ⇒
            Middleware
            m
            (Conn req { writer ∷ rw | res } c)
            (Conn req { writer ∷ rw | res } c)
            rw
getWriter = _.response.writer <$> getConn

setStatus ∷ ∀ req res c m e.
            MonadEff (http ∷ HTTP | e) m
          ⇒ Status
          → HTTP.Response
          → Middleware m (Conn req res c) (Conn req res c) Unit
setStatus (Status { code, reasonPhrase }) r = liftEff do
  HTTP.setStatusCode r code
  HTTP.setStatusMessage r reasonPhrase

writeHeader' ∷ ∀ req res c m e.
               MonadEff (http ∷ HTTP | e) m
             ⇒ (Tuple String String)
             → HTTP.Response
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeHeader' (Tuple name value) r =
  liftEff $ HTTP.setHeader r name value

writeResponse ∷ ∀ req res c m e.
                MonadAff (http ∷ HTTP | e) m
             ⇒ HTTP.Response
             → NodeResponse m (http :: HTTP | e)
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeResponse r (NodeResponse f) =
  lift' (f (HTTP.responseAsStream r))

endResponse ∷ ∀ req res c m e.
              MonadEff (http ∷ HTTP | e) m
            ⇒ HTTP.Response
            → Middleware m (Conn req res c) (Conn req res c) Unit
endResponse r =
  liftEff (Stream.end (HTTP.responseAsStream r) (pure unit))

instance responseWriterHttpResponse :: MonadAff (http ∷ HTTP | e) m
                                    => Response HttpResponse m (NodeResponse m (http :: HTTP | e)) where
  writeStatus status =
    getConn :>>= \{ response: HttpResponse r } ->
      setStatus status r
      :*> modifyConn (_ { response = HttpResponse r })

  writeHeader header =
    getConn :>>= \{ response: HttpResponse r } ->
      writeHeader' header r
      :*> modifyConn (_ { response = HttpResponse r })

  closeHeaders =
    getConn :>>= \{ response: HttpResponse r } ->
      modifyConn (_ { response = HttpResponse r })

  send f =
    getConn :>>= \{ response: HttpResponse r } ->
      writeResponse r f
      :*> modifyConn (_ { response = HttpResponse r })

  end =
    getConn :>>= \{ response: HttpResponse r } ->
      endResponse r
      :*> modifyConn (_ { response = HttpResponse r })

mkHttpRequest :: HTTP.Request -> HttpRequest
mkHttpRequest request =
  HttpRequest request requestData
  where
    headers = HTTP.requestHeaders request
    requestData =
      { url: HTTP.requestURL request
      , parsedUrl: defer \_ -> parseUrl (HTTP.requestURL request)
      , headers: headers
      , method: Method.fromString (HTTP.requestMethod request)
      , contentLength: StrMap.lookup "content-length" headers
                      >>= Int.fromString
      }

runServer'
  :: forall m e c c'
   . Functor m
  => Options e
  -> c
  -> (forall a. m a -> Aff (http :: HTTP | e) a)
  -> Middleware
     m
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer' options components runM middleware = do
  server <- HTTP.createServer onRequest
  let listenOptions = { port: unwrap options.port
                      , hostname: unwrap options.hostname
                      , backlog: Nothing
                      }
  HTTP.listen server listenOptions (options.onListening options.hostname options.port)
  where
    onRequest ∷ HTTP.Request → HTTP.Response → Eff (http :: HTTP | e) Unit
    onRequest request response =
      let conn = { request: mkHttpRequest request
                 , response: HttpResponse response
                 , components: components
                 }
      in catchException options.onRequestError (void (launchAff (runM (evalMiddleware middleware conn))))

runServer
  :: forall e c c'.
     Options e
  -> c
  -> Middleware
     (Aff (http :: HTTP | e))
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer options components middleware =
  runServer' options components id middleware


implement asks and asksAt (#26)

implement asks and asksAt (#26)

module Run.Reader
  ( Reader(..)
  , READER
  , _reader
  , liftReader
  , liftReaderAt
  , ask
  , askAt
  , local
  , localAt
  , runReader
  , runReaderAt
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Symbol (class IsSymbol)
import Prim.Row as Row
import Run (Run, SProxy(..), FProxy)
import Run as Run

newtype Reader e a = Reader (e → a)

derive newtype instance functorReader ∷ Functor (Reader e)

type READER e = FProxy (Reader e)

_reader ∷ SProxy "reader"
_reader = SProxy

liftReader ∷ ∀ e a r. Reader e a → Run (reader ∷ READER e | r) a
liftReader = liftReaderAt _reader

liftReaderAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → Reader e a
  → Run r a
liftReaderAt = Run.lift

ask ∷ ∀ e r. Run (reader ∷ READER e | r) e
ask = askAt _reader

askAt ∷
  ∀ t e r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → Run r e
askAt sym = asksAt sym identity

asks ∷ ∀ e r a. (e → a) → Run (reader ∷ READER e | r) a
asks = asksAt _reader

asksAt ∷
  ∀ t e r s a
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → (e → a)
  → Run r a
asksAt sym f = liftReaderAt sym (Reader f)

local ∷ ∀ e a r. (e → e) → Run (reader ∷ READER e | r) a → Run (reader ∷ READER e | r) a
local = localAt _reader

localAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → (e → e)
  → Run r a
  → Run r a
localAt sym = \f r → map f (askAt sym) >>= flip runLocal r
  where
  handle = Run.on sym Left Right
  runLocal = loop
    where
    loop e r = case Run.peel r of
      Left a → case handle a of
        Left (Reader k) →
          loop e (k e)
        Right _ →
          Run.send a >>= runLocal e
      Right a →
        pure a

runReader ∷ ∀ e a r. e → Run (reader ∷ READER e | r) a → Run r a
runReader = runReaderAt _reader

runReaderAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → e
  → Run r a
  → Run t a
runReaderAt sym = loop
  where
  handle = Run.on sym Left Right
  loop e r = case Run.peel r of
    Left a → case handle a of
      Left (Reader k) →
        loop e (k e)
      Right a' →
        Run.send a' >>= runReaderAt sym e
    Right a →
      pure a

module Run.Reader
  ( Reader(..)
  , READER
  , _reader
  , liftReader
  , liftReaderAt
  , ask
  , askAt
  , local
  , localAt
  , runReader
  , runReaderAt
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Symbol (class IsSymbol)
import Prim.Row as Row
import Run (Run, SProxy(..), FProxy)
import Run as Run

newtype Reader e a = Reader (e → a)

derive newtype instance functorReader ∷ Functor (Reader e)

type READER e = FProxy (Reader e)

_reader ∷ SProxy "reader"
_reader = SProxy

liftReader ∷ ∀ e a r. Reader e a → Run (reader ∷ READER e | r) a
liftReader = liftReaderAt _reader

liftReaderAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → Reader e a
  → Run r a
liftReaderAt = Run.lift

ask ∷ ∀ e r . Run (reader ∷ READER e | r) e
ask = askAt _reader

askAt ∷
  ∀ t e r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → Run r e
askAt sym = liftReaderAt sym (Reader identity)

local ∷ ∀ e a r. (e → e) → Run (reader ∷ READER e | r) a → Run (reader ∷ READER e | r) a
local = localAt _reader

localAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → (e → e)
  → Run r a
  → Run r a
localAt sym = \f r → map f (askAt sym) >>= flip runLocal r
  where
  handle = Run.on sym Left Right
  runLocal = loop
    where
    loop e r = case Run.peel r of
      Left a → case handle a of
        Left (Reader k) →
          loop e (k e)
        Right _ →
          Run.send a >>= runLocal e
      Right a →
        pure a

runReader ∷ ∀ e a r. e → Run (reader ∷ READER e | r) a → Run r a
runReader = runReaderAt _reader

runReaderAt ∷
  ∀ t e a r s
  . IsSymbol s
  ⇒ Row.Cons s (READER e) t r
  ⇒ SProxy s
  → e
  → Run r a
  → Run t a
runReaderAt sym = loop
  where
  handle = Run.on sym Left Right
  loop e r = case Run.peel r of
    Left a → case handle a of
      Left (Reader k) →
        loop e (k e)
      Right a' →
        Run.send a' >>= runReaderAt sym e
    Right a →
      pure a


Fix genDate generator frequency (#83)

Fix genDate generator frequency (#83)

module Data.Date.Gen
  ( genDate
  , module Data.Date.Component.Gen
  ) where

import Prelude
import Control.Monad.Gen (class MonadGen, chooseInt)
import Data.Date (Date, adjust, exactDate, isLeapYear)
import Data.Date.Component.Gen (genDay, genMonth, genWeekday, genYear)
import Data.Int (toNumber)
import Data.Maybe (fromJust)
import Data.Time.Duration (Days(..))
import Partial.Unsafe (unsafePartial)

-- | Generates a random `Date` between 1st Jan 1900 and 31st Dec 2100,
-- | inclusive.
genDate :: forall m. MonadGen m => m Date
genDate = do
  year <- genYear
  let maxDays = if isLeapYear year then 365 else 364
  days <- Days <<< toNumber <$> chooseInt 0 maxDays
  pure $ unsafePartial $ fromJust do
    janFirst <- exactDate year bottom bottom
    adjust days janFirst

module Data.Date.Gen
  ( genDate
  , module Data.Date.Component.Gen
  ) where

import Prelude
import Control.Monad.Gen (class MonadGen)
import Data.Date (Date, canonicalDate)
import Data.Date.Component.Gen (genDay, genMonth, genWeekday, genYear)

-- | Generates a random `Date` between 1st Jan 1900 and 31st Dec 2100,
-- | inclusive.
genDate :: forall m. MonadGen m => m Date
genDate = canonicalDate <$> genYear <*> genMonth <*> genDay


Update QTL feature source to use type level units

module Genetics.Browser.Source.QTL
       where

import Prelude
import Data.Map as Map
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Data.Array (fromFoldable, mapMaybe)
import Data.Either (Either(..))
import Data.Foreign (Foreign)
import Data.Foreign.Null (writeNull)
import Data.Function.Uncurried (Fn4, Fn7, mkFn7, runFn4)
import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Genetics.Browser.Feature (Feature, feature, withFeature)
import Genetics.Browser.Units (Bp, MBp(MBp), bp)
import Global (readFloat)
import Network.HTTP.Affjax (AJAX, get)
import Text.Parsing.CSV (defaultParsers)
import Text.Parsing.Parser (parseErrorMessage, runParser)
import Unsafe.Coerce (unsafeCoerce)

type QTLFeature = Feature Bp (score :: Number)

                  -- the first Foreign should be Nullable Feature or similar
type FetchCallback = Fn4 String Foreign Number Foreign (Aff (ajax :: AJAX) Unit)

-- Feature should be in this... maybe
type SourceImpl = ∀ eff. String -> Number -> Number
                  -> Number -> Foreign -> Foreign
                  -> FetchCallback -> Aff (ajax :: AJAX | eff) Unit

type Source = ∀ eff. Fn7 String Number Number
                       Number Foreign Foreign
                       FetchCallback (Aff (ajax :: AJAX | eff) Unit)

-- if we have some way of transforming response bodies to features,
-- as well as an URI to get them from, we can make a Source usable by BD.
-- we also need a way to translate chr, min, max (and the other args?)
-- into e.g. URI parameters, or filtering the output based on them...

-- so it's not quite this simple. the Source needs to actually _do_ things
-- based on the parameters, i.e. the Source is actually parametericized on
-- how we fetch the actually data!

-- meaning there's another level of abstraction, or another part that can be pulled out.
-- type AnySource = ∀ r. (String -> Array (Feature r)) -> String -> Source

-- fetch :: Source
fetch :: _
fetch uri = mkFn7 $ fetchImpl uri

featureFilter :: String -> QTLFeature -> Maybe QTLFeature
featureFilter chr f' = if (withFeature (\f -> f.chr == chr) f') then Just f' else Nothing

fetchImpl :: _
fetchImpl uri chr pmin pmax scale types pool f = launchAff $ do
  res <- get uri
  let parsed = runParser res.response defaultParsers.fileHeaded
      results = map (lineToFeature >=> featureFilter chr) <$> parsed

  -- traceAny "fetching!!!" $ const (pure unit)
  -- traceAny (fromFoldable <$> results) $ const (pure unit)

  case fromFoldable <$> results of
    Left  er -> unsafeCoerce $
                runFn4 f (parseErrorMessage er) writeNull 0.0 writeNull
    Right fs -> unsafeCoerce $ let fs' = mapMaybe id fs -- filtering away Nothings
                in runFn4 f "" (unsafeCoerce fs') 0.0 writeNull

-- not very safe or stable (case sensitive, numbers as strings...)
lineToFeature :: Map String String -> Maybe QTLFeature
lineToFeature m = do
  chr <- Map.lookup "Chr" m
    -- Convert MBp to Bp in a type safe manner
  min <- bp <$> MBp <$> readFloat <$> Map.lookup "Mb" m
  score <- readFloat <$> (Map.lookup "LRS" m <|> Map.lookup "LOD" m)
  pure $ feature { chr: chr, min: min, max: min, score: score }

module Genetics.Browser.Source.QTL
       where

import Prelude

import Text.Parsing.CSV (defaultParsers)
import Text.Parsing.Parser (parseErrorMessage, runParser)
import Data.Map as Map
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff)
import Data.Array (fromFoldable, mapMaybe)
import Data.Either (Either(..))
import Data.Foreign (Foreign)
import Data.Foreign.Null (writeNull)
import Data.Function.Uncurried (Fn4, runFn4)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Genetics.Browser.Feature (Feature(..))
import Global (readFloat)
import Network.HTTP.Affjax (AJAX, get)
import Unsafe.Coerce (unsafeCoerce)

type QTLFeature = Feature (score :: Number)

                  -- the first Foreign should be Nullable Feature or similar
type FetchCallback = ∀ r. Fn4 String Foreign Number Foreign (Aff (ajax :: AJAX | r) Unit)

-- Feature should be in this, and 'r' should be the row in Feature r
type Source r =  String -> Number -> Number
              -> Number -> Foreign -> Foreign
              -> FetchCallback -> Aff (ajax :: AJAX | r) Unit

fetch :: Source ()
fetch chr pmin pmax scale types pool f = do
  res <- get "http://test-gn2.genenetwork.org/api_pre1/qtl/lod2.csv"
  let parsed = runParser res.response defaultParsers.fileHeaded
      results = (map lineToFeature) <$> parsed
  case fromFoldable <$> results of
    Left  er -> unsafeCoerce $
                runFn4 f (parseErrorMessage er) writeNull 0.0 writeNull
    Right fs -> unsafeCoerce $ let fs' = mapMaybe id fs -- filtering away Nothings
                in runFn4 f "features" (unsafeCoerce fs') 0.0 writeNull

-- not very safe or stable (case sensitive, numbers as strings...)
lineToFeature :: Map String String -> Maybe QTLFeature
lineToFeature m = do
  chr <- Map.lookup "Chr" m
  min <- readFloat <$> Map.lookup "Mb" m
  score <- readFloat <$> (Map.lookup "LRS" m <|> Map.lookup "LOD" m)
  pure $ Feature { chr: chr, min: min, max: min, score: score }


Use "title" in JSON Schema for classes

Use "title" in JSON Schema for classes

Original commit 7c95de1db9b78d3ae44bbe7fa82548ba295427e9

module JsonSchema where

import Doc
import IRGraph
import Prelude

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldM, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyMultipleTypes, unifyTypes)
import Utils (foldError, mapM, mapMapM, mapStrMapM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

newtype JSONSchemaRef = JSONSchemaRef (NEL.NonEmptyList String)

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    , title :: Maybe String
    }

decodeEnum :: forall a. StrMap a -> Json -> Either String a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        ref <- decodeJson j
        case NEL.fromFoldable $ String.split (String.Pattern "/") ref of
            Just nel -> pure $ JSONSchemaRef nel
            Nothing -> Left "ERROR: String.split should return at least one element."

decodeTypes :: Maybe Json -> Either String (Maybe (Either JSONType (Set JSONType)))
decodeTypes Nothing = Right Nothing
decodeTypes (Just j) =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> either Left (\t -> Right $ Just $ Left t) $ decodeEnum jsonTypeEnumMap j)
        (\a -> either Left (\l -> Right $ Just $ Right $ S.fromFoldable l) $ foldError $ map (decodeEnum jsonTypeEnumMap) a)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either String (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"
        types <- decodeTypes $ SM.lookup "type" obj
        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        title <- obj .?? "title"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required, title }

lookupRef :: JSONSchema -> List String -> JSONSchema -> Either String JSONSchema
lookupRef root ref local@(JSONSchema { definitions }) =
    case ref of
    L.Nil -> Right local
    "#" : rest -> lookupRef root rest root
    "definitions" : name : rest ->
        case definitions of
        Just sm ->
            case SM.lookup name sm of
            Just js -> lookupRef root rest js
            Nothing -> Left "Reference not found"
        Nothing -> Left "Definitions not found"
    _ -> Left "Reference not supported"

toIRAndUnify :: forall a f. Foldable f => (a -> IR (Either String IRType)) -> f a -> IR (Either String IRType)
toIRAndUnify toIR l = do
    irsAndErrors <- mapM toIR $ L.fromFoldable l
    let irsOrError = foldError irsAndErrors
    either (\e -> pure $ Left e) (\irs -> Right <$> foldM unifyTypes IRNothing irs) irsOrError

jsonSchemaToIR :: JSONSchema -> Either String String -> JSONSchema -> IR (Either String IRType)
jsonSchemaToIR root name schema@(JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required })
    | Just (JSONSchemaRef r) <- ref =
        case lookupRef root (NEL.toList r) schema of
        Left err -> pure $ Left err
        Right js -> jsonSchemaToIR root (Left $ NEL.last r) js
    | Just (Left jt) <- types =
        jsonTypeToIR root name jt schema
    | Just (Right jts) <- types =
        toIRAndUnify (\jt -> jsonTypeToIR root name jt schema) jts
    | Just jss <- oneOf =
        toIRAndUnify (jsonSchemaToIR root name) jss
    | otherwise =
        pure $ Right IRNothing

jsonSchemaListToIR :: forall t. Traversable t => Either String String -> t JSONSchema -> IR (Either String IRType)
jsonSchemaListToIR name l = do
    errorOrTypeList <- mapM (\js -> jsonSchemaToIR js name js) l
    case foldError errorOrTypeList of
        Left err -> pure $ Left err
        Right irTypes -> Right <$> unifyMultipleTypes irTypes

jsonTypeToIR :: JSONSchema -> Either String String -> JSONType -> JSONSchema -> IR (Either String IRType)
jsonTypeToIR root name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            propsAndErrorsWrong :: List _ <- SM.toUnfoldable <$> mapStrMapM (\n -> jsonSchemaToIR root $ Right n) sm
            let propsOrError = M.fromFoldable <$> (foldError $ map raiseTuple propsAndErrorsWrong)
            let required = maybe S.empty S.fromFoldable schema.required
            let title = maybe name Left schema.title
            nulledPropsOrError <- either (\x -> pure $ Left x) (\x -> Right <$> mapMapM (\n -> if S.member n required then pure else unifyTypes IRNull) x) propsOrError
            classFromPropsOrError title nulledPropsOrError
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ Right $ IRMap IRNothing
            Left false ->
                pure $ Right $ IRNothing
            Right js -> do
                irOrError <- jsonSchemaToIR root singularName js
                pure $ either Left (\ir -> Right $ IRMap ir) irOrError
    JSONArray ->
        case schema.items of
        Just js -> do
            itemIROrError <- (jsonSchemaToIR root singularName) js
            pure $ either Left (\ir -> Right $ IRArray ir) itemIROrError
        Nothing -> pure $ Right $ IRArray IRNothing
    JSONBoolean -> pure $ Right IRBool
    JSONString -> pure $ Right IRString
    JSONNull -> pure $ Right IRNull
    JSONInteger -> pure $ Right IRInteger
    JSONNumber -> pure $ Right IRDouble
    where
        classFromPropsOrError :: Either String String -> Either String (Map String IRType) -> IR (Either String IRType)
        classFromPropsOrError title =
            case _ of
            Left err -> pure $ Left err
            Right props -> do
                Right <$> (addClass $ makeClass title props)
        raiseTuple :: Tuple String (Either String IRType) -> Either String (Tuple String IRType)
        raiseTuple (Tuple k irOrError) =
            either Left (\ir -> Right $ Tuple k ir) irOrError
        singularName = Right $ singular $ either id id name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "JSON Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Nothing
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: simpleNamer jsonNameStyle -- FIXME: put title on top levels, too
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> jsonNameStyle
    # intercalate "Or"

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRNothing -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapM jsonForType $ L.fromFoldable $ unionToSet ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List _)
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    let withTitle = SM.insert "title" (fromString className) withRequired
    pure $ Tuple className $ fromObject withTitle

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    -- FIXME: give a title to top-levels, too
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json

module JsonSchema where

import Doc
import IRGraph
import Prelude

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldM, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyMultipleTypes, unifyTypes)
import Utils (foldError, mapM, mapMapM, mapStrMapM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

newtype JSONSchemaRef = JSONSchemaRef (NEL.NonEmptyList String)

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    }

decodeEnum :: forall a. StrMap a -> Json -> Either String a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        ref <- decodeJson j
        case NEL.fromFoldable $ String.split (String.Pattern "/") ref of
            Just nel -> pure $ JSONSchemaRef nel
            Nothing -> Left "ERROR: String.split should return at least one element."

decodeTypes :: Maybe Json -> Either String (Maybe (Either JSONType (Set JSONType)))
decodeTypes Nothing = Right Nothing
decodeTypes (Just j) =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> either Left (\t -> Right $ Just $ Left t) $ decodeEnum jsonTypeEnumMap j)
        (\a -> either Left (\l -> Right $ Just $ Right $ S.fromFoldable l) $ foldError $ map (decodeEnum jsonTypeEnumMap) a)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either String (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"
        types <- decodeTypes $ SM.lookup "type" obj
        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required }

lookupRef :: JSONSchema -> List String -> JSONSchema -> Either String JSONSchema
lookupRef root ref local@(JSONSchema { definitions }) =
    case ref of
    L.Nil -> Right local
    "#" : rest -> lookupRef root rest root
    "definitions" : name : rest ->
        case definitions of
        Just sm ->
            case SM.lookup name sm of
            Just js -> lookupRef root rest js
            Nothing -> Left "Reference not found"
        Nothing -> Left "Definitions not found"
    _ -> Left "Reference not supported"

toIRAndUnify :: forall a f. Foldable f => (a -> IR (Either String IRType)) -> f a -> IR (Either String IRType)
toIRAndUnify toIR l = do
    irsAndErrors <- mapM toIR $ L.fromFoldable l
    let irsOrError = foldError irsAndErrors
    either (\e -> pure $ Left e) (\irs -> Right <$> foldM unifyTypes IRNothing irs) irsOrError

jsonSchemaToIR :: JSONSchema -> Either String String -> JSONSchema -> IR (Either String IRType)
jsonSchemaToIR root name schema@(JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required })
    | Just (JSONSchemaRef r) <- ref =
        case lookupRef root (NEL.toList r) schema of
        Left err -> pure $ Left err
        Right js -> jsonSchemaToIR root (Left $ NEL.last r) js
    | Just (Left jt) <- types =
        jsonTypeToIR root name jt schema
    | Just (Right jts) <- types =
        toIRAndUnify (\jt -> jsonTypeToIR root name jt schema) jts
    | Just jss <- oneOf =
        toIRAndUnify (jsonSchemaToIR root name) jss
    | otherwise =
        pure $ Right IRNothing

jsonSchemaListToIR :: forall t. Traversable t => Either String String -> t JSONSchema -> IR (Either String IRType)
jsonSchemaListToIR name l = do
    errorOrTypeList <- mapM (\js -> jsonSchemaToIR js name js) l
    case foldError errorOrTypeList of
        Left err -> pure $ Left err
        Right irTypes -> Right <$> unifyMultipleTypes irTypes

jsonTypeToIR :: JSONSchema -> Either String String -> JSONType -> JSONSchema -> IR (Either String IRType)
jsonTypeToIR root name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            propsAndErrorsWrong :: List _ <- SM.toUnfoldable <$> mapStrMapM (\n -> jsonSchemaToIR root $ Right n) sm
            let propsOrError = M.fromFoldable <$> (foldError $ map raiseTuple propsAndErrorsWrong)
            let required = maybe S.empty S.fromFoldable schema.required
            nulledPropsOrError <- either (\x -> pure $ Left x) (\x -> Right <$> mapMapM (\n -> if S.member n required then pure else unifyTypes IRNull) x) propsOrError
            classFromPropsOrError nulledPropsOrError
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ Right $ IRMap IRNothing
            Left false ->
                pure $ Right $ IRNothing
            Right js -> do
                irOrError <- jsonSchemaToIR root singularName js
                pure $ either Left (\ir -> Right $ IRMap ir) irOrError
    JSONArray ->
        case schema.items of
        Just js -> do
            itemIROrError <- (jsonSchemaToIR root singularName) js
            pure $ either Left (\ir -> Right $ IRArray ir) itemIROrError
        Nothing -> pure $ Right $ IRArray IRNothing
    JSONBoolean -> pure $ Right IRBool
    JSONString -> pure $ Right IRString
    JSONNull -> pure $ Right IRNull
    JSONInteger -> pure $ Right IRInteger
    JSONNumber -> pure $ Right IRDouble
    where
        classFromPropsOrError :: Either String (Map String IRType) -> IR (Either String IRType)
        classFromPropsOrError =
            case _ of
            Left err -> pure $ Left err
            Right props -> do
                Right <$> (addClass $ makeClass name props)
        raiseTuple :: Tuple String (Either String IRType) -> Either String (Tuple String IRType)
        raiseTuple (Tuple k irOrError) =
            either Left (\ir -> Right $ Tuple k ir) irOrError
        singularName = Right $ singular $ either id id name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "JSON Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Nothing
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: simpleNamer jsonNameStyle
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> jsonNameStyle
    # intercalate "Or"

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRNothing -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapM jsonForType $ L.fromFoldable $ unionToSet ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List _)
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    pure $ Tuple className $ fromObject withRequired

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json


d’oh: type parameters are parameters edition

many thanks to garyb

module D3.Base
  ( module Control.Monad.Eff
  , D3
  , D3Element
  , D3Typenames
  , ListenerType(..)
  , Typenames(..)
  , Point
  , D3SetWithIndex
  , AttrSetter(..)
  , ClassSetter(..)
  , DataBind(..)
  , Filter(..)
  , PolyValue(..)
  , Index
  , Nodes
  , (..)
  , (...)
  , PredicateFn
  , PredicateB
  , PredicateS
  , PredicateN
  , theHorror
  ) where

import Control.Monad.Eff (Eff)
import Data.Array ((:))
import Data.Foldable (foldr, intercalate)
import Data.Foreign.Null (writeNull)
import Data.Function (applyFlipped)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (show, class Show, bind, (<>), ($))
import Unsafe.Coerce (unsafeCoerce)

-- || FFI for D3
foreign import data D3 :: !
foreign import data D3Element :: *

type D3Eff a = ∀ e. Eff (d3 :: D3 | e) a

type Index       = Number
type D3Typenames = String
type Nodes       = Array D3Element
type Point       = { x :: Number, y :: Number }

data ListenerType = StartDrag | Drag | EndDrag
                  | StartZoom | Zoom | EndZoom

instance isShowListenerType :: Show ListenerType where
  show StartDrag = "start"
  show Drag      = "drag"
  show EndDrag   = "end"
  show StartZoom = "start"
  show Zoom      = "zoom"
  show EndZoom   = "end"

data Typenames = TypeNames (Array { name :: Maybe String, type :: ListenerType })

-- smush the Typenames down to a single string which D3 will (wastefully) parse out again)
instance isShowTypenames :: Show Typenames where
  show (TypeNames s) = intercalate " " $ foldr f [] s
    where
      f {name: (Just n), type: t } acc = ((show t) <> "." <> n) : acc
      f {name: Nothing,  type: t } acc =             (show t)  : acc

theHorror :: ∀ t0. t0
theHorror = unsafeCoerce writeNull

foreign import approxZero :: Number

-- | These next two operators are really key to making this DSL look like D3 in JavaScript
-- | All respect to pelotom for cooking them up in the original purescript-d3!

-- Syntactic sugar to make chained monadic statements look similar to the
-- "fluid interface" style of chained method calls in JavaScript
infixl 4 bind as ..
-- Reversed function application, useful for applying extended monadic chains
-- to already-obtained values
infixl 4 applyFlipped as ...

-- for selection.classed and selection.attr:
type PredicateFn    d x = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) x)
type PredicateB     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) Boolean)
type PredicateS     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) String)
type PredicateN     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) Number)
type D3SetWithIndex d v = ∀ eff. (d -> Index -> Eff (d3::D3|eff) v)

-- | ADT used to wrap those polymorphic calls in D3 which take either
--      a value, or...
--      a function to get a value from the datum, or...
--      a function to get a value from the datum and its index
data DataBind d k = Data (Array d)
                  | Keyed (Array d) (d -> k)

data PolyValue d v  = Value v
                    | SetByIndex (D3SetWithIndex d v)

data Filter d       = Selector  String
                    | Predicate (d -> Boolean)

data ClassSetter  d = SetAll Boolean
                    | SetSome (PredicateB d)

data AttrSetter d x = SetAttr x
                    | AttrFn (PredicateFn d x)   -- rename both data ctor and Type here TODO

module D3.Base
  ( module Control.Monad.Eff
  , D3
  , D3Element
  , D3Typenames
  , ListenerType(..)
  , Typenames(..)
  , Point
  , D3SetWithIndex
  , AttrSetter(..)
  , ClassSetter(..)
  , DataBind(..)
  , Filter(..)
  , PolyValue(..)
  , Index
  , Nodes
  , (..)
  , (...)
  , PredicateFn
  , PredicateB
  , PredicateS
  , PredicateN
  , theHorror
  ) where

import Control.Monad.Eff (Eff)
import Data.Array ((:))
import Data.Foldable (foldr, intercalate)
import Data.Foreign.Null (writeNull)
import Data.Function (applyFlipped)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (show, class Show, bind, (<>), ($))
import Unsafe.Coerce (unsafeCoerce)

-- || FFI for D3
foreign import data D3 :: !
foreign import data D3Element :: *

type D3Eff a = ∀ e. Eff (d3 :: D3 | e) a

type Index       = Number
type D3Typenames = String
type Nodes       = Array D3Element
type Point       = { x :: Number, y :: Number }

data ListenerType = StartDrag | Drag | EndDrag
                  | StartZoom | Zoom | EndZoom

instance isShowListenerType :: Show ListenerType where
  show StartDrag = "start"
  show Drag      = "drag"
  show EndDrag   = "end"
  show StartZoom = "start"
  show Zoom      = "zoom"
  show EndZoom   = "end"

data Typenames = TypeNames (Array { name :: Maybe String, type :: ListenerType })

-- smush the Typenames down to a single string which D3 will (wastefully) parse out again)
instance isShowTypenames :: Show Typenames where
  show (TypeNames s) = intercalate " " $ foldr f [] s
    where
      f {name: (Just n), type: t } acc = ((show t) <> "." <> n) : acc
      f {name: Nothing,  type: t } acc =             (show t)  : acc

theHorror :: ∀ t0. t0
theHorror = unsafeCoerce writeNull

foreign import approxZero :: Number

-- | These next two operators are really key to making this DSL look like D3 in JavaScript
-- | All respect to pelotom for cooking them up in the original purescript-d3!

-- Syntactic sugar to make chained monadic statements look similar to the
-- "fluid interface" style of chained method calls in JavaScript
infixl 4 bind as ..
-- Reversed function application, useful for applying extended monadic chains
-- to already-obtained values
infixl 4 applyFlipped as ...

-- for selection.classed and selection.attr:
type PredicateFn  x d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) x)
type PredicateB     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) Boolean)
type PredicateS     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) String)
type PredicateN     d   = ∀ eff. (d -> Number -> (Array D3Element) -> D3Element -> Eff (d3::D3|eff) Number)
type D3SetWithIndex d v = ∀ eff. (d -> Index -> Eff (d3::D3|eff) v)

-- | ADT used to wrap those polymorphic calls in D3 which take either
--      a value, or...
--      a function to get a value from the datum, or...
--      a function to get a value from the datum and its index
data DataBind d k = Data (Array d)
                  | Keyed (Array d) (d -> k)

data PolyValue d v  = Value v
                    | SetByIndex (D3SetWithIndex d v)

data Filter d       = Selector  String
                    | Predicate (d -> Boolean)

data ClassSetter  d = SetAll Boolean
                    | SetSome (PredicateB d)

data AttrSetter d x = SetAttr x
                    | AttrFn (PredicateFn d x)   -- rename both data ctor and Type here TODO