feat: Node.Express.App -> expose hidden methods

module Node.Express.App
    ( AppM
    , App
    , HandlerFn
    , listenHttp, listenHttps, listenHostHttp, listenHostHttps
    , listenPipe, makeHttpServer, makeHttpsServer, apply
    , use, useExternal, useAt, useAtExternal, useOnParam, useOnError
    , getProp, setProp
    , http, get, post, put, delete, all

    , mkApplication, _getProp, _setProp, _http, _httpServer, _httpsServer, _listenHttp, _listenHttps
    , _listenHostHttp, _listenHostHttps, _listenPipe, _use, _useExternal, _useAt, _useAtExternal, _useOnParam, _useOnError
    ) where

import Prelude hiding (apply)

import Data.Function.Uncurried (Fn2, Fn3, Fn4, runFn4, runFn3, runFn2)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Foreign (Foreign, unsafeToForeign)
import Node.Express.Handler (Handler, runHandlerM)
import Node.Express.Types (class RoutePattern, Application, Response, Request, Event, Host, Path, Port, Pipe, Method(..), Middleware)
import Node.HTTP (Server)

-- | Monad responsible for application related operations (initial setup mostly).
data AppM a = AppM (Application -> Effect a)
type App = AppM Unit

type HandlerFn = Request -> Response -> Effect Unit -> Effect Unit

instance functorAppM :: Functor AppM where
    map f (AppM h) = AppM \app -> liftM1 f $ h app

instance applyAppM :: Apply AppM where
    apply (AppM f) (AppM h) = AppM \app -> do
        res <- h app
        trans <- f app
        pure $ trans res

instance applicativeAppM :: Applicative AppM where
    pure x = AppM \_ -> pure x

instance bindAppM :: Bind AppM where
    bind (AppM h) f = AppM \app -> do
        res <- h app
        case f res of
             AppM g -> g app

instance monadAppM :: Monad AppM

instance monadEffectAppM :: MonadEffect AppM where
    liftEffect act = AppM \_ -> act

-- | Create a Node.HTTP server from the Express application.
-- | HTTP version
makeHttpServer :: App -> Effect Server
makeHttpServer (AppM act) = do
    app <- mkApplication
    act app
    _httpServer app

-- | Create a Node.HTTP server from the Express application.
-- | HTTPS version
makeHttpsServer :: App -> Effect Server
makeHttpsServer (AppM act) = do
    app <- mkApplication
    act app
    _httpsServer app

-- | Run application on specified port and execute callback after launch.
-- | HTTP version
listenHttp :: App -> Port -> (Event -> Effect Unit) -> Effect Server
listenHttp (AppM act) port cb = do
    app <- mkApplication
    act app
    _listenHttp app port cb

-- | Run application on specified port and execute callback after launch.
-- | HTTPS version
listenHttps :: forall opts.
    App -> Port -> opts -> (Event -> Effect Unit) -> Effect Server
listenHttps (AppM act) port opts cb = do
    app <- mkApplication
    act app
    _listenHttps app port opts cb

-- | Run application on specified port & host and execute callback after launch.
-- | HTTP version
listenHostHttp :: App -> Port -> Host -> (Event -> Effect Unit) -> Effect Server
listenHostHttp (AppM act) port host cb = do
    app <- mkApplication
    act app
    _listenHostHttp app port host cb

-- | Run application on specified port & host and execute callback after launch.
-- | HTTPS version
listenHostHttps :: forall opts.
    App -> Port -> Host-> opts -> (Event -> Effect Unit) -> Effect Server
listenHostHttps (AppM act) port host opts cb = do
    app <- mkApplication
    act app
    _listenHostHttps app port host opts cb

-- | Run application on specified named pipe and execute callback after launch.
-- | HTTP version
listenPipe :: App -> Pipe -> (Event -> Effect Unit) -> Effect Server
listenPipe (AppM act) pipe cb = do
    app <- mkApplication
    act app
    _listenPipe app pipe cb

-- | Apply App actions to existent Express.js application
apply :: App -> Application -> Effect Unit
apply (AppM act) app = act app

-- | Use specified middleware handler.
use :: Handler -> App
use middleware = AppM \app ->
    runFn2 _use app $ runHandlerM middleware

-- | Use any function as middleware.
-- | Introduced to ease usage of a bunch of external
-- | middleware written for express.js.
-- | See http://expressjs.com/4x/api.html#middleware
useExternal :: Middleware -> App
useExternal fn = AppM \app ->
    runFn2 _useExternal app fn

-- | Use specified middleware only on requests matching path.
useAt :: Path -> Handler -> App
useAt route middleware = AppM \app ->
    runFn3 _useAt app route $ runHandlerM middleware

-- | Use any function as middleware only on requests matching path.
-- | Introduced to ease usage of a bunch of external
-- | middleware written for express.js.
-- | See http://expressjs.com/4x/api.html#middleware
useAtExternal :: Path -> Middleware -> App
useAtExternal route fn = AppM \app ->
    runFn3 _useAtExternal app route fn

-- | Process route param with specified handler.
useOnParam :: String -> (String -> Handler) -> App
useOnParam param handler = AppM \app ->
    runFn3 _useOnParam app param (runHandlerM <<< handler)

-- | Use error handler. Probably this should be the last middleware to attach.
useOnError :: (Error -> Handler) -> App
useOnError handler = AppM \app ->
    runFn2 _useOnError app (runHandlerM <<< handler)

-- | Get application property.
-- | See http://expressjs.com/4x/api.html#app-settings
getProp :: forall a. String -> AppM (Maybe a)
getProp name = AppM \app ->
    liftEffect $ runFn4 _getProp app name Nothing Just

-- | Set application property.
-- | See http://expressjs.com/4x/api.html#app-settings
setProp :: forall a. String -> a -> App
setProp name val = AppM \app ->
    runFn3 _setProp app name val

-- | Bind specified handler to handle request matching route and method.
http :: forall r. (RoutePattern r) => Method -> r -> Handler -> App
http method route handler = AppM \app ->
    runFn4 _http app (show method) (unsafeToForeign route) $ runHandlerM handler

-- | Shortcut for `http GET`.
get :: forall r. (RoutePattern r) => r -> Handler -> App
get = http GET

-- | Shortcut for `http POST`.
post :: forall r. (RoutePattern r) => r -> Handler -> App
post = http POST

-- | Shortcut for `http PUT`.
put :: forall r. (RoutePattern r) => r -> Handler -> App
put = http PUT

-- | Shortcut for `http DELETE`.
delete :: forall r. (RoutePattern r) => r -> Handler -> App
delete = http DELETE

-- | Shortcut for `http ALL` (match on any http method).
all :: forall r. (RoutePattern r) => r -> Handler -> App
all = http ALL

foreign import mkApplication :: Effect Application

foreign import _getProp :: forall a. Fn4 Application String (Maybe a) (a -> Maybe a) (Effect (Maybe a))

foreign import _setProp :: forall a. Fn3 Application String a (Effect Unit)

foreign import _http :: Fn4 Application String Foreign HandlerFn (Effect Unit)

foreign import _httpServer :: Application -> Effect Server

foreign import _httpsServer :: Application -> Effect Server

foreign import _listenHttp :: Application -> Int -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHttps :: forall opts. Application -> Int -> opts -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHostHttp :: Application -> Int -> String -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHostHttps :: forall opts. Application -> Int -> String -> opts -> (Event -> Effect Unit) -> Effect Server

foreign import _listenPipe :: Application -> String -> (Event -> Effect Unit) -> Effect Server

foreign import _use :: Fn2 Application HandlerFn (Effect Unit)

foreign import _useExternal :: Fn2 Application Middleware (Effect Unit)

foreign import _useAt :: Fn3 Application String (HandlerFn) (Effect Unit)

foreign import _useAtExternal :: Fn3 Application String Middleware (Effect Unit)

foreign import _useOnParam :: Fn3 Application String (String -> HandlerFn) (Effect Unit)

foreign import _useOnError :: Fn2 Application (Error -> HandlerFn) (Effect Unit)

module Node.Express.App
    ( AppM
    , App
    , listenHttp, listenHttps, listenHostHttp, listenHostHttps
    , listenPipe, makeHttpServer, makeHttpsServer, apply
    , use, useExternal, useAt, useAtExternal, useOnParam, useOnError
    , getProp, setProp
    , http, get, post, put, delete, all
    ) where

import Prelude hiding (apply)

import Data.Function.Uncurried (Fn2, Fn3, Fn4, runFn4, runFn3, runFn2)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Foreign (Foreign, unsafeToForeign)
import Node.Express.Handler (Handler, runHandlerM)
import Node.Express.Types (class RoutePattern, Application, Response, Request, Event, Host, Path, Port, Pipe, Method(..), Middleware)
import Node.HTTP (Server)

-- | Monad responsible for application related operations (initial setup mostly).
data AppM a = AppM (Application -> Effect a)
type App = AppM Unit

type HandlerFn = Request -> Response -> Effect Unit -> Effect Unit

instance functorAppM :: Functor AppM where
    map f (AppM h) = AppM \app -> liftM1 f $ h app

instance applyAppM :: Apply AppM where
    apply (AppM f) (AppM h) = AppM \app -> do
        res <- h app
        trans <- f app
        pure $ trans res

instance applicativeAppM :: Applicative AppM where
    pure x = AppM \_ -> pure x

instance bindAppM :: Bind AppM where
    bind (AppM h) f = AppM \app -> do
        res <- h app
        case f res of
             AppM g -> g app

instance monadAppM :: Monad AppM

instance monadEffectAppM :: MonadEffect AppM where
    liftEffect act = AppM \_ -> act

-- | Create a Node.HTTP server from the Express application.
-- | HTTP version
makeHttpServer :: App -> Effect Server
makeHttpServer (AppM act) = do
    app <- mkApplication
    act app
    _httpServer app

-- | Create a Node.HTTP server from the Express application.
-- | HTTPS version
makeHttpsServer :: App -> Effect Server
makeHttpsServer (AppM act) = do
    app <- mkApplication
    act app
    _httpsServer app

-- | Run application on specified port and execute callback after launch.
-- | HTTP version
listenHttp :: App -> Port -> (Event -> Effect Unit) -> Effect Server
listenHttp (AppM act) port cb = do
    app <- mkApplication
    act app
    _listenHttp app port cb

-- | Run application on specified port and execute callback after launch.
-- | HTTPS version
listenHttps :: forall opts.
    App -> Port -> opts -> (Event -> Effect Unit) -> Effect Server
listenHttps (AppM act) port opts cb = do
    app <- mkApplication
    act app
    _listenHttps app port opts cb

-- | Run application on specified port & host and execute callback after launch.
-- | HTTP version
listenHostHttp :: App -> Port -> Host -> (Event -> Effect Unit) -> Effect Server
listenHostHttp (AppM act) port host cb = do
    app <- mkApplication
    act app
    _listenHostHttp app port host cb

-- | Run application on specified port & host and execute callback after launch.
-- | HTTPS version
listenHostHttps :: forall opts.
    App -> Port -> Host-> opts -> (Event -> Effect Unit) -> Effect Server
listenHostHttps (AppM act) port host opts cb = do
    app <- mkApplication
    act app
    _listenHostHttps app port host opts cb

-- | Run application on specified named pipe and execute callback after launch.
-- | HTTP version
listenPipe :: App -> Pipe -> (Event -> Effect Unit) -> Effect Server
listenPipe (AppM act) pipe cb = do
    app <- mkApplication
    act app
    _listenPipe app pipe cb

-- | Apply App actions to existent Express.js application
apply :: App -> Application -> Effect Unit
apply (AppM act) app = act app

-- | Use specified middleware handler.
use :: Handler -> App
use middleware = AppM \app ->
    runFn2 _use app $ runHandlerM middleware

-- | Use any function as middleware.
-- | Introduced to ease usage of a bunch of external
-- | middleware written for express.js.
-- | See http://expressjs.com/4x/api.html#middleware
useExternal :: Middleware -> App
useExternal fn = AppM \app ->
    runFn2 _useExternal app fn

-- | Use specified middleware only on requests matching path.
useAt :: Path -> Handler -> App
useAt route middleware = AppM \app ->
    runFn3 _useAt app route $ runHandlerM middleware

-- | Use any function as middleware only on requests matching path.
-- | Introduced to ease usage of a bunch of external
-- | middleware written for express.js.
-- | See http://expressjs.com/4x/api.html#middleware
useAtExternal :: Path -> Middleware -> App
useAtExternal route fn = AppM \app ->
    runFn3 _useAtExternal app route fn

-- | Process route param with specified handler.
useOnParam :: String -> (String -> Handler) -> App
useOnParam param handler = AppM \app ->
    runFn3 _useOnParam app param (runHandlerM <<< handler)

-- | Use error handler. Probably this should be the last middleware to attach.
useOnError :: (Error -> Handler) -> App
useOnError handler = AppM \app ->
    runFn2 _useOnError app (runHandlerM <<< handler)

-- | Get application property.
-- | See http://expressjs.com/4x/api.html#app-settings
getProp :: forall a. String -> AppM (Maybe a)
getProp name = AppM \app ->
    liftEffect $ runFn4 _getProp app name Nothing Just

-- | Set application property.
-- | See http://expressjs.com/4x/api.html#app-settings
setProp :: forall a. String -> a -> App
setProp name val = AppM \app ->
    runFn3 _setProp app name val

-- | Bind specified handler to handle request matching route and method.
http :: forall r. (RoutePattern r) => Method -> r -> Handler -> App
http method route handler = AppM \app ->
    runFn4 _http app (show method) (unsafeToForeign route) $ runHandlerM handler

-- | Shortcut for `http GET`.
get :: forall r. (RoutePattern r) => r -> Handler -> App
get = http GET

-- | Shortcut for `http POST`.
post :: forall r. (RoutePattern r) => r -> Handler -> App
post = http POST

-- | Shortcut for `http PUT`.
put :: forall r. (RoutePattern r) => r -> Handler -> App
put = http PUT

-- | Shortcut for `http DELETE`.
delete :: forall r. (RoutePattern r) => r -> Handler -> App
delete = http DELETE

-- | Shortcut for `http ALL` (match on any http method).
all :: forall r. (RoutePattern r) => r -> Handler -> App
all = http ALL

foreign import mkApplication :: Effect Application

foreign import _getProp :: forall a. Fn4 Application String (Maybe a) (a -> Maybe a) (Effect (Maybe a))

foreign import _setProp :: forall a. Fn3 Application String a (Effect Unit)

foreign import _http :: Fn4 Application String Foreign HandlerFn (Effect Unit)

foreign import _httpServer :: Application -> Effect Server

foreign import _httpsServer :: Application -> Effect Server

foreign import _listenHttp :: Application -> Int -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHttps :: forall opts. Application -> Int -> opts -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHostHttp :: Application -> Int -> String -> (Event -> Effect Unit) -> Effect Server

foreign import _listenHostHttps :: forall opts. Application -> Int -> String -> opts -> (Event -> Effect Unit) -> Effect Server

foreign import _listenPipe :: Application -> String -> (Event -> Effect Unit) -> Effect Server

foreign import _use :: Fn2 Application HandlerFn (Effect Unit)

foreign import _useExternal :: Fn2 Application Middleware (Effect Unit)

foreign import _useAt :: Fn3 Application String (HandlerFn) (Effect Unit)

foreign import _useAtExternal :: Fn3 Application String Middleware (Effect Unit)

foreign import _useOnParam :: Fn3 Application String (String -> HandlerFn) (Effect Unit)

foreign import _useOnError :: Fn2 Application (Error -> HandlerFn) (Effect Unit)


Cancel the other branch when there's succeess in a race

module Control.Monad.Aff
  ( Aff
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , finally
  , forkAff
  , forkAll
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  , ParAff(..)
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _makeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadZero, class MonadPlus)
import Control.Parallel (class Parallel)
import Control.Plus (class Plus, empty)

import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldl)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)

import Unsafe.Coerce (unsafeCoerce)

-- | An asynchronous computation with effects `e`. The computation either
-- | errors or produces a value of type `a`.
-- |
-- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
foreign import data Aff :: # ! -> * -> *

-- | A pure asynchronous computation, having no effects other than
-- | asynchronous computation.
type PureAff a = forall e. Aff e a

-- | A canceler is an asynchronous function that can be used to attempt the
-- | cancelation of a computation. Returns a boolean flag indicating whether
-- | or not the cancellation was successful. Many computations may be composite,
-- | in such cases the flag indicates whether any part of the computation was
-- | successfully canceled. The flag should not be used for communication.
newtype Canceler e = Canceler (Error -> Aff e Boolean)

-- | Unwraps the canceler function from the newtype that wraps it.
cancel :: forall e. Canceler e -> Error -> Aff e Boolean
cancel (Canceler f) = f

-- | This function allows you to attach a custom canceler to an asynchronous
-- | computation. If the computation is canceled, then the custom canceler
-- | will be run along side the computation's own canceler.
cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

-- | Converts the asynchronous computation into a synchronous one. All values
-- | are ignored, and if the computation produces an error, it is thrown.
-- |
-- | Catching exceptions by using `catchException` with the resulting Eff
-- | computation is not recommended, as exceptions may end up being thrown
-- | asynchronously, in which case they cannot be caught.
-- |
-- | If you do need to handle exceptions, you can use `runAff` instead, or
-- | you can handle the exception within the Aff computation, using
-- | `catchError` (or any of the other mechanisms).
launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) (Canceler e)
launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx
  where
  liftEx :: Aff e a -> Aff (err :: EXCEPTION | e) a
  liftEx = _unsafeInterleaveAff
  lowerEx :: Eff (err :: EXCEPTION | e) (Canceler (err :: EXCEPTION | e)) -> Eff (err :: EXCEPTION | e) (Canceler e)
  lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel)

-- | Runs the asynchronous computation. You must supply an error callback and a
-- | success callback.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | asynchronous computation.
runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e (Canceler e)
runAff ex f aff = runFn3 _runAff ex f aff

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks. This function can be used for asynchronous computations
-- | that cannot be canceled.
makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks, and returns a canceler for the computation. This
-- | function can be used for asynchronous computations that can be canceled.
makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
makeAff' h = _makeAff h

-- | Runs the asynchronous computation off the current execution context.
later :: forall e a. Aff e a -> Aff e a
later = later' 0

-- | Runs the specified asynchronous computation later, by the specified
-- | number of milliseconds.
later' :: forall e a. Int -> Aff e a -> Aff e a
later' n aff = runFn3 _setTimeout nonCanceler n aff

-- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
finally aff1 aff2 = do
  x <- attempt aff1
  aff2
  either throwError pure x

-- | Forks the specified asynchronous computation so subsequent computations
-- | will not block on the result of the computation.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | forked computation.
forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
forkAff aff = runFn2 _forkAff nonCanceler aff

-- | Forks many asynchronous computation in a synchronous manner while being
-- | stack-safe up to the selected Foldable instance.
-- |
-- | Returns a canceler that can be used to attempt cancellation of all
-- | forked computations.
forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
forkAll affs = runFn3 _forkAll nonCanceler foldl affs

-- | Promotes any error to the value level of the asynchronous monad.
attempt :: forall e a. Aff e a -> Aff e (Either Error a)
attempt aff = runFn3 _attempt Left Right aff

-- | Ignores any errors.
apathize :: forall e a. Aff e a -> Aff e Unit
apathize a = const unit <$> attempt a

-- | Lifts a synchronous computation and makes explicit any failure from exceptions.
liftEff' :: forall e a. Eff (err :: EXCEPTION | e) a -> Aff e (Either Error a)
liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

-- | A constant canceller that always returns false.
nonCanceler :: forall e. Canceler e
nonCanceler = Canceler (const (pure false))

-- | A constant canceller that always returns true.
alwaysCanceler :: forall e. Canceler e
alwaysCanceler = Canceler (const (pure true))

instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
  append a b = (<>) <$> a <*> b

instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
  mempty = pure mempty

instance functorAff :: Functor (Aff e) where
  map f fa = runFn2 _fmap f fa

instance applyAff :: Apply (Aff e) where
  apply ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

instance applicativeAff :: Applicative (Aff e) where
  pure v = runFn2 _pure nonCanceler v

instance bindAff :: Bind (Aff e) where
  bind fa f = runFn3 _bind alwaysCanceler fa f

instance monadAff :: Monad (Aff e)

instance monadEffAff :: MonadEff e (Aff e) where
  liftEff eff = runFn2 _liftEff nonCanceler eff

-- | Allows users to catch and throw errors on the error channel of the
-- | asynchronous computation. See documentation in `purescript-transformers`.
instance monadErrorAff :: MonadError Error (Aff e) where
  throwError e = runFn2 _throwError nonCanceler e

  catchError aff ex = attempt aff >>= either ex pure

instance altAff :: Alt (Aff e) where
  alt a1 a2 = attempt a1 >>= either (const a2) pure

instance plusAff :: Plus (Aff e) where
  empty = throwError $ error "Always fails"

instance alternativeAff :: Alternative (Aff e)

instance monadZero :: MonadZero (Aff e)

instance monadPlusAff :: MonadPlus (Aff e)

instance monadRecAff :: MonadRec (Aff e) where
  tailRecM f a = runFn3 _tailRecM isLoop f a
    where
    isLoop (Loop _) = true
    isLoop _ = false

instance semigroupCanceler :: Semigroup (Canceler e) where
  append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

instance monoidCanceler :: Monoid (Canceler e) where
  mempty = Canceler (const (pure true))

newtype ParAff e a = ParAff (Aff e a)

derive instance newtypeParAff :: Newtype (ParAff e a) _

instance semigroupParAff :: (Semigroup a) => Semigroup (ParAff e a) where
  append a b = append <$> a <*> b

instance monoidParAff :: (Monoid a) => Monoid (ParAff e a) where
  mempty = pure mempty

derive newtype instance functorParAff :: Functor (ParAff e)

instance applyParAff :: Apply (ParAff e) where
  apply (ParAff ff) (ParAff fa) = ParAff do
    va <- makeVar
    vb <- makeVar
    c1 <- forkAff (putOrKill va =<< attempt ff)
    c2 <- forkAff (putOrKill vb =<< attempt fa)
    (takeVar va <*> takeVar vb) `cancelWith` (c1 <> c2)
    where
    putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit
    putOrKill v = either (killVar v) (putVar v)

instance applicativeParAff :: Applicative (ParAff e) where
  pure = ParAff <<< pure

-- | Returns the first value, or the first error if both error.
instance altParAff :: Alt (ParAff e) where
  alt (ParAff a1) (ParAff a2) = ParAff do
    va <- makeVar -- the `a` value
    ve <- makeVar -- the error count (starts at 0)
    cs <- makeVar -- the cancelers
    putVar ve 0
    c1 <- forkAff $ either (maybeKill va ve) (done cs snd va) =<< attempt a1
    c2 <- forkAff $ either (maybeKill va ve) (done cs fst va) =<< attempt a2
    putVar cs (Tuple c1 c2)
    takeVar va `cancelWith` (c1 <> c2)
    where
    done :: forall a. AVar (Tuple (Canceler e) (Canceler e)) -> (forall x. Tuple x x -> x) -> AVar a -> a -> Aff e Unit
    done cs get va x = do
      putVar va x
      c <- get <$> takeVar cs
      void $ cancel c (error "Alt early exit")
    maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
    maybeKill va ve err = do
      e <- takeVar ve
      when (e == 1) $ killVar va err
      putVar ve (e + 1)

instance plusParAff :: Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff :: Alternative (ParAff e)

instance parallelParAff :: Parallel (ParAff e) (Aff e) where
  parallel = ParAff
  sequential (ParAff ma) = ma

makeVar :: forall e a. Aff e (AVar a)
makeVar = fromAVBox $ _makeVar nonCanceler

takeVar :: forall e a. AVar a -> Aff e a
takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q

putVar :: forall e a. AVar a -> a -> Aff e Unit
putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a

killVar :: forall e a. AVar a -> Error -> Aff e Unit
killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e

fromAVBox :: forall a e. AVBox a -> Aff e a
fromAVBox = unsafeCoerce

foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

foreign import _setTimeout :: forall e a. Fn3 (Canceler e) Int (Aff e a) (Aff e a)

foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a

foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e))

foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a)

foreign import _throwError :: forall e a. Fn2 (Canceler e) Error (Aff e a)

foreign import _fmap :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

foreign import _attempt :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e (Canceler e))

foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)

foreign import _tailRecM :: forall e a b. Fn3 (Step a b -> Boolean) (a -> Aff e (Step a b)) a (Aff e b)

module Control.Monad.Aff
  ( Aff
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , finally
  , forkAff
  , forkAll
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  , ParAff(..)
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _makeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadZero, class MonadPlus)
import Control.Parallel (class Parallel)
import Control.Plus (class Plus, empty)

import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldl)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)

import Unsafe.Coerce (unsafeCoerce)

-- | An asynchronous computation with effects `e`. The computation either
-- | errors or produces a value of type `a`.
-- |
-- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
foreign import data Aff :: # ! -> * -> *

-- | A pure asynchronous computation, having no effects other than
-- | asynchronous computation.
type PureAff a = forall e. Aff e a

-- | A canceler is an asynchronous function that can be used to attempt the
-- | cancelation of a computation. Returns a boolean flag indicating whether
-- | or not the cancellation was successful. Many computations may be composite,
-- | in such cases the flag indicates whether any part of the computation was
-- | successfully canceled. The flag should not be used for communication.
newtype Canceler e = Canceler (Error -> Aff e Boolean)

-- | Unwraps the canceler function from the newtype that wraps it.
cancel :: forall e. Canceler e -> Error -> Aff e Boolean
cancel (Canceler f) = f

-- | This function allows you to attach a custom canceler to an asynchronous
-- | computation. If the computation is canceled, then the custom canceler
-- | will be run along side the computation's own canceler.
cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

-- | Converts the asynchronous computation into a synchronous one. All values
-- | are ignored, and if the computation produces an error, it is thrown.
-- |
-- | Catching exceptions by using `catchException` with the resulting Eff
-- | computation is not recommended, as exceptions may end up being thrown
-- | asynchronously, in which case they cannot be caught.
-- |
-- | If you do need to handle exceptions, you can use `runAff` instead, or
-- | you can handle the exception within the Aff computation, using
-- | `catchError` (or any of the other mechanisms).
launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) (Canceler e)
launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx
  where
  liftEx :: Aff e a -> Aff (err :: EXCEPTION | e) a
  liftEx = _unsafeInterleaveAff
  lowerEx :: Eff (err :: EXCEPTION | e) (Canceler (err :: EXCEPTION | e)) -> Eff (err :: EXCEPTION | e) (Canceler e)
  lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel)

-- | Runs the asynchronous computation. You must supply an error callback and a
-- | success callback.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | asynchronous computation.
runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e (Canceler e)
runAff ex f aff = runFn3 _runAff ex f aff

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks. This function can be used for asynchronous computations
-- | that cannot be canceled.
makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks, and returns a canceler for the computation. This
-- | function can be used for asynchronous computations that can be canceled.
makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
makeAff' h = _makeAff h

-- | Runs the asynchronous computation off the current execution context.
later :: forall e a. Aff e a -> Aff e a
later = later' 0

-- | Runs the specified asynchronous computation later, by the specified
-- | number of milliseconds.
later' :: forall e a. Int -> Aff e a -> Aff e a
later' n aff = runFn3 _setTimeout nonCanceler n aff

-- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
finally aff1 aff2 = do
  x <- attempt aff1
  aff2
  either throwError pure x

-- | Forks the specified asynchronous computation so subsequent computations
-- | will not block on the result of the computation.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | forked computation.
forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
forkAff aff = runFn2 _forkAff nonCanceler aff

-- | Forks many asynchronous computation in a synchronous manner while being
-- | stack-safe up to the selected Foldable instance.
-- |
-- | Returns a canceler that can be used to attempt cancellation of all
-- | forked computations.
forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
forkAll affs = runFn3 _forkAll nonCanceler foldl affs

-- | Promotes any error to the value level of the asynchronous monad.
attempt :: forall e a. Aff e a -> Aff e (Either Error a)
attempt aff = runFn3 _attempt Left Right aff

-- | Ignores any errors.
apathize :: forall e a. Aff e a -> Aff e Unit
apathize a = const unit <$> attempt a

-- | Lifts a synchronous computation and makes explicit any failure from exceptions.
liftEff' :: forall e a. Eff (err :: EXCEPTION | e) a -> Aff e (Either Error a)
liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

-- | A constant canceller that always returns false.
nonCanceler :: forall e. Canceler e
nonCanceler = Canceler (const (pure false))

-- | A constant canceller that always returns true.
alwaysCanceler :: forall e. Canceler e
alwaysCanceler = Canceler (const (pure true))

instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
  append a b = (<>) <$> a <*> b

instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
  mempty = pure mempty

instance functorAff :: Functor (Aff e) where
  map f fa = runFn2 _fmap f fa

instance applyAff :: Apply (Aff e) where
  apply ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

instance applicativeAff :: Applicative (Aff e) where
  pure v = runFn2 _pure nonCanceler v

instance bindAff :: Bind (Aff e) where
  bind fa f = runFn3 _bind alwaysCanceler fa f

instance monadAff :: Monad (Aff e)

instance monadEffAff :: MonadEff e (Aff e) where
  liftEff eff = runFn2 _liftEff nonCanceler eff

-- | Allows users to catch and throw errors on the error channel of the
-- | asynchronous computation. See documentation in `purescript-transformers`.
instance monadErrorAff :: MonadError Error (Aff e) where
  throwError e = runFn2 _throwError nonCanceler e

  catchError aff ex = attempt aff >>= either ex pure

instance altAff :: Alt (Aff e) where
  alt a1 a2 = attempt a1 >>= either (const a2) pure

instance plusAff :: Plus (Aff e) where
  empty = throwError $ error "Always fails"

instance alternativeAff :: Alternative (Aff e)

instance monadZero :: MonadZero (Aff e)

instance monadPlusAff :: MonadPlus (Aff e)

instance monadRecAff :: MonadRec (Aff e) where
  tailRecM f a = runFn3 _tailRecM isLoop f a
    where
    isLoop (Loop _) = true
    isLoop _ = false

instance semigroupCanceler :: Semigroup (Canceler e) where
  append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

instance monoidCanceler :: Monoid (Canceler e) where
  mempty = Canceler (const (pure true))

newtype ParAff e a = ParAff (Aff e a)

derive instance newtypeParAff :: Newtype (ParAff e a) _

instance semigroupParAff :: (Semigroup a) => Semigroup (ParAff e a) where
  append a b = append <$> a <*> b

instance monoidParAff :: (Monoid a) => Monoid (ParAff e a) where
  mempty = pure mempty

derive newtype instance functorParAff :: Functor (ParAff e)

instance applyParAff :: Apply (ParAff e) where
  apply (ParAff ff) (ParAff fa) = ParAff do
    va <- makeVar
    vb <- makeVar
    c1 <- forkAff (putOrKill va =<< attempt ff)
    c2 <- forkAff (putOrKill vb =<< attempt fa)
    (takeVar va <*> takeVar vb) `cancelWith` (c1 <> c2)
    where
    putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit
    putOrKill v = either (killVar v) (putVar v)

instance applicativeParAff :: Applicative (ParAff e) where
  pure = ParAff <<< pure

-- | Returns the first value, or the first error if both error.
instance altParAff :: Alt (ParAff e) where
  alt (ParAff a1) (ParAff a2) = ParAff do
    va <- makeVar -- the `a` value
    ve <- makeVar -- the error count (starts at 0)
    putVar ve 0
    c1 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a1
    c2 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a2
    takeVar va `cancelWith` (c1 <> c2)
    where
    maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
    maybeKill va ve err = do
      e <- takeVar ve
      when (e == 1) $ killVar va err
      putVar ve (e + 1)

instance plusParAff :: Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff :: Alternative (ParAff e)

instance parallelParAff :: Parallel (ParAff e) (Aff e) where
  parallel = ParAff
  sequential (ParAff ma) = ma

makeVar :: forall e a. Aff e (AVar a)
makeVar = fromAVBox $ _makeVar nonCanceler

takeVar :: forall e a. AVar a -> Aff e a
takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q

putVar :: forall e a. AVar a -> a -> Aff e Unit
putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a

killVar :: forall e a. AVar a -> Error -> Aff e Unit
killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e

fromAVBox :: forall a e. AVBox a -> Aff e a
fromAVBox = unsafeCoerce

foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

foreign import _setTimeout :: forall e a. Fn3 (Canceler e) Int (Aff e a) (Aff e a)

foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a

foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e))

foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a)

foreign import _throwError :: forall e a. Fn2 (Canceler e) Error (Aff e a)

foreign import _fmap :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

foreign import _attempt :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e (Canceler e))

foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)

foreign import _tailRecM :: forall e a b. Fn3 (Step a b -> Boolean) (a -> Aff e (Step a b)) a (Aff e b)


prelude lol

prelude lol

module Components.Init where

import Prelude
import Components.Typer (State, Circle)
import Data.Array ((!!), (..))
import Data.Maybe (Maybe(Nothing), fromMaybe)

initialState :: State
initialState =
  { name: "."
  , drag: Nothing
  , circles: sampleCircles
  }

sampleCircles :: Array Circle
sampleCircles = do
  x <- values
  y <- values
  pure { x: mm x, y: mm y, r: 30, c: findcolor x }
  where
  colors = ["red", "green", "blue", "yellow", "pink"]
  values = 1 .. 5
  mm = (\n -> 30 + n * 70 )
  findcolor x = colors !! x # fromMaybe "black"

defaultCircle :: Circle
defaultCircle = { x:1, y:1, r:1, c: "white" }

module Components.Init where

import Components.Typer (State, Circle)
import Data.Array ((!!), (..))
import Data.Maybe (Maybe(Nothing), fromMaybe)
import Prelude -- (bind, pure, (#), ($), (*), (+))

initialState :: State
initialState =
  { name: "."
  , drag: Nothing
  , circles: sampleCircles
  }

sampleCircles :: Array Circle
sampleCircles = do
  x <- values
  y <- values
  pure { x: mm x, y: mm y, r: 30, c: findcolor x }
  where
  colors = ["red", "green", "blue", "yellow", "pink"]
  values = 1 .. 5
  mm = (\n -> 30 + n * 70 )
  findcolor x = colors !! x # fromMaybe "black"

defaultCircle :: Circle
defaultCircle = { x:1, y:1, r:1, c: "white" }


Use topological sort in Go

Use topological sort in Go

Original commit 6323c2948760a2f3ec6c2e870b195a80059ec2a0

module Language.Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    renderRenderItems blank (Just renderTopLevel) renderGolangType renderGolangUnion
    unless (unions == L.Nil) do
        blank
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""

renderTopLevel :: String -> IRType -> Doc Unit
renderTopLevel topLevelName topLevelType = do
    { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
    line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
    line $ "    var r " <> topLevelName
    line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
    line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
    indent do
        line "return json.Marshal(r)"
    line "}"

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: String -> Set IRType -> Doc Unit
renderGolangUnion name allTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Language.Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    forEachTopLevel_ \topLevelName topLevelType -> do
        { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
        blank
        line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
        blank
        line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
        line $ "    var r " <> topLevelName
        line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
        line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
        indent do
            line "return json.Marshal(r)"
        line "}"
    blank
    forEachClass_ \className properties -> do
        renderGolangType className properties
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderGolangUnion unionName unionTypes

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: String -> Set IRType -> Doc Unit
renderGolangUnion name allTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p


New level in chapter 1, remove unnecessary rejectB transformer

module Levels.Chapter1 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: SM.fromList [
        "stackEqual" :> {
            name: "stackEqual",
            function: tStackEqual
        },
        "replaceYbyB" :> {
            name: "map({Yellow} ↦ {Brown})",
            function: tReplace Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map({Yellow} ↦ {Brown}{Yellow})",
            function: tReplaceMultiple Yellow [Brown, Yellow]
        },
        "replaceBbyOO" :> {
            name: "map({Brown} ↦ {Orange}{Orange})",
            function: tReplaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "reject({Orange})",
            function: map (reject (== Orange)) >>> tClearEmpty
        },
        "pushY" :> {
            name: "map(push({Yellow}))",
            function: map (`snoc` Yellow)
        }
    ],

    levels: SM.fromList [
        "1.1" :> {
            name: "Dismiss",
            difficulty: Easy,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1.2" :> {
            name: "Gizeh",
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown, Brown, Brown, Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown]]
        },
        "1.3" :> {
            name: "Poseidon",
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Brown], [Brown, Brown, Brown, Brown], [Brown], [Brown, Brown]]
        },
        "1.4" :> {
            name: "Bowl",
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        },
        "1.5" :> {
            name: "Stamp",
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Yellow], [Yellow], [Yellow, Yellow, Yellow, Yellow], [Yellow], [Yellow]]
        }
    ]
}

module Levels.Chapter1 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: SM.fromList [
        "stackEqual" :> {
            name: "stackEqual",
            function: tStackEqual
        },
        "replaceYbyB" :> {
            name: "map({Yellow} ↦ {Brown})",
            function: tReplace Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map({Yellow} ↦ {Brown}{Yellow})",
            function: tReplaceMultiple Yellow [Brown, Yellow]
        },
        "replaceBbyOO" :> {
            name: "map({Brown} ↦ {Orange}{Orange})",
            function: tReplaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "reject({Orange})",
            function: map (reject (== Orange)) >>> tClearEmpty
        },
        "rejectB" :> {
            name: "reject({Brown})",
            function: map (reject (== Brown)) >>> tClearEmpty
        },
        "pushY" :> {
            name: "map(push({Yellow}))",
            function: map (`snoc` Yellow)
        }
    ],

    levels: SM.fromList [
        "1.1" :> {
            name: "Dismiss",
            difficulty: Easy,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1.2" :> {
            name: "Gizeh",
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown, Brown, Brown, Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown]]
        },
        "1.3" :> {
            name: "Poseidon",
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Brown], [Brown, Brown, Brown, Brown], [Brown], [Brown, Brown]]
        },
        "1.4" :> {
            name: "Bowl",
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        }
    ]
}


added '' to list of string parsed to Nothing

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Model.Notebook.ECharts
  ( analyzeJArray
  , getPossibleDependencies
  , dependsOn
  , isComplement
  , Axis(..)
  , Semantics(..)
  , isValue
  , isPercent
  , isMoney
  , isBool
  , isTime
  , isCategory
  , isValAxis
  , isCatAxis
  , isTimeAxis
  , runAxis
  , catFromSemantics
  , valFromSemantics
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.MonadPlus (guard)
import Data.Argonaut.Core (Json(), JArray(), toNumber, toString)
import Data.Argonaut.JCursor (JCursor(..), JsonPrim(), toPrims, runJsonPrim, insideOut)
import Data.Array (filter, concat, nubBy, singleton, sortBy, head, reverse, length, tail, (!!), (:), nub, elemIndex)
import Data.Bifunctor (rmap)
import Data.Foldable (for_, traverse_, foldl, fold, Foldable)
import Data.Traversable (traverse, sequence)
import Data.Function (on)
import Data.Map (fromList, Map(), toList, empty, alter, insert, keys, lookup, delete, update)
import Data.Maybe (Maybe(..), maybe, isJust, isNothing, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Monoid.Conj (Conj(..), runConj)
import Data.String (take)
import Data.String.Regex (noFlags, regex, match, test)
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat, isNaN)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, jsonEmptyObject, JArray(), Json())
import Data.Either
import Data.Unfoldable (Unfoldable)
import Utils (s2n, s2i)
import qualified Data.List as L
import qualified Data.StrMap as Sm

dependsOn :: JCursor -> JCursor -> Boolean
dependsOn a b = a /= b &&
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

instance encodeJsonSemantics :: EncodeJson Semantics where
  encodeJson (Value n) = "type" := "value"
                         ~> "value" := n
                         ~> jsonEmptyObject

  encodeJson (Percent n) = "type" := "percent"
                           ~> "value" := n
                           ~> jsonEmptyObject

  encodeJson (Money n v) = "type" := "money"
                           ~> "value" := n
                           ~> "currency" := v
                           ~> jsonEmptyObject

  encodeJson (Bool b) = "type" := "bool"
                        ~> "value" := b
                        ~> jsonEmptyObject

  encodeJson (Category c) = "type" := "category"
                            ~> "value" := c
                            ~> jsonEmptyObject

  encodeJson (Time t) = "type" := "time"
                        ~> "value" := t
                        ~> jsonEmptyObject

instance decodeJsonSemantics :: DecodeJson Semantics where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    case ty of
      "money" -> do
        curr <- obj .? "currency"
        m <- obj .? "value"
        pure (Money m curr)
      "time" -> do
        t <- obj .? "value"
        pure $ Time t
      "bool" -> do
        b <- obj .? "value"
        pure $ Bool b
      "category" -> do
        c <- obj .? "value"
        pure $ Category c
      "value" -> do
        v <- obj .? "value"
        pure $ Value v
      "percent" -> do
        p <- obj .? "value"
        pure $ Percent p
      _ -> Left "incorrect type of semanthic"

data Axis
  = ValAxis (L.List (Maybe Semantics))
  | CatAxis (L.List (Maybe Semantics))
  | TimeAxis (L.List (Maybe Semantics))

instance encodeJsonAxis :: EncodeJson Axis where
  encodeJson (ValAxis mbs) = "type" := "val-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (CatAxis mbs) = "type" := "cat-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (TimeAxis mbs) = "type" := "time-axis"
                              ~> "els" := mbs
                              ~> jsonEmptyObject

instance decodeJsonAxis :: DecodeJson Axis where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    mbs <- obj .? "els"
    case ty of
      "val-axis" -> pure $ ValAxis mbs
      "cat-axis" -> pure $ CatAxis mbs
      "time-axis" -> pure $ TimeAxis mbs
      _ -> Left "incorrect axis type"

isValAxis :: Axis -> Boolean
isValAxis (ValAxis _) = true
isValAxis _ = false

isCatAxis :: Axis -> Boolean
isCatAxis (CatAxis _) = true
isCatAxis _ = false

isTimeAxis :: Axis -> Boolean
isTimeAxis (TimeAxis _) = true
isTimeAxis _ = false

runAxis :: Axis -> L.List (Maybe Semantics)
runAxis (ValAxis a) = a
runAxis (CatAxis a) = a
runAxis (TimeAxis a) = a

instance axisShow :: Show Axis where
  show (ValAxis vs) = "(ValAxis " <> show vs <> ")"
  show (CatAxis vs) = "(CatAxis " <> show vs <> ")"
  show (TimeAxis vs) = "(TimeAxis " <> show vs <> ")"

isValue :: Semantics -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semantics -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semantics -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semantics -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semantics -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semantics -> Boolean
isTime (Time _) = true
isTime _ = false

isComplement :: Axis -> Axis -> Boolean
isComplement (CatAxis _) (CatAxis _) = false
isComplement (TimeAxis _) (TimeAxis _) = false
isComplement _ _ = true

catFromSemantics :: Semantics -> Maybe String
catFromSemantics v =
  case v of
    Value v -> pure $ show v
    Percent v -> pure $ show v <> "%"
    Money v m -> pure $ show v <> m
    Category s -> pure s
    Time t -> pure t
    Bool b -> pure $ show b

valFromSemantics :: Semantics -> Maybe Number
valFromSemantics v =
  case v of
    Value v -> pure v
    Money v _ -> pure v
    Percent v -> pure v
    _ -> Nothing

checkSemantics :: L.List (Maybe Semantics) -> Maybe Axis
checkSemantics lst =
  (ValAxis  <$> checkValues lst)   <|>
  (ValAxis  <$> checkMoney lst)    <|>
  (ValAxis  <$> checkPercent lst)  <|>
  (ValAxis  <$> checkBool lst)     <|>
  (TimeAxis <$> checkTime lst)     <|>
  (CatAxis  <$> checkCategory lst)

checkPredicate :: (Semantics -> Boolean) -> L.List (Maybe Semantics) ->
                  Maybe (L.List (Maybe Semantics))
checkPredicate p lst =
  go 0 0 lst L.Nil
  where
  -- traversed. If there is more correct value then incorrect return
  -- list with filtered values. else nothing.
  go correct incorrect L.Nil acc
    | correct > incorrect = Just $ L.reverse acc
    | otherwise = Nothing
  -- There is no value. Just put it to acc don't touch counters
  go correct incorrect (L.Cons Nothing lst) acc =
    go correct incorrect lst (L.Cons Nothing acc)
  -- There is a value
  go correct incorrect (L.Cons (Just c) lst) acc
    -- It means nothing. Put Nothing to accum and don't touch counters
    | isJust $ elemIndex c nothings = go correct incorrect lst (L.Cons Nothing acc)
    -- It's correct. Increase correct counter, put value to accum
    | p c = go (correct + one) incorrect lst (L.Cons (Just c) acc)
    -- It's incorrect. Increase incorrect counter, put nothing to accum
    | otherwise = go correct (incorrect + one) lst (L.Cons Nothing acc)

  nothings :: Array Semantics
  nothings = map Category [ "undefined"
                          , "null"
                          , "NA"
                          , "N/A"
                          , ""
                          ]

checkValues :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkValues = checkPredicate isValue

checkMoney :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkMoney = checkPredicate isMoney

checkPercent :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkPercent = checkPredicate isPercent

checkBool :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkBool = checkPredicate isBool

checkTime :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkTime = checkPredicate isTime

checkCategory :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkCategory = checkPredicate isCategory

instance semanthicShow :: Show Semantics where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semantics where
  eq (Value v) (Value v') = v == v'
  eq (Value v) _ = false
  eq (Percent p) (Percent p') = p == p'
  eq (Percent _) _ = false
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Money _ _) _ = false
  eq (Time t) (Time t') = t == t'
  eq (Time _) _ = false
  eq (Category c) (Category c') = c == c'
  eq (Category _) _ = false
  eq (Bool b) (Bool b') = b == b'
  eq (Bool _) _ = false

instance semanthicOrd :: Ord Semantics where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'
  compare (Category _) _ = LT
  compare (Bool b) (Bool b') = compare b b'
  compare (Bool _) _ = LT

analyze :: JsonPrim -> Maybe Semantics
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semantics
analyzeString str =
  (analyzeDate str) <|>
  (analyzeNumber str) <|>
  (analyzeMoney str) <|>
  (analyzePercent str) <|>
  (Just $ Category str)

analyzeNumber :: String -> Maybe Semantics
analyzeNumber s = do
  num <- s2n s
  i <- s2i s
  guard $ show num == s || show i == s
  pure $ Value num

analyzePercent :: String -> Maybe Semantics
analyzePercent input = do
  ms <- match rgx input
  s <- (ms !! 1)
  n <- (s >>= s2n)
  pure $ Percent n
  where rgx = regex """^(-?\d+(\.\d+)?)\%$""" noFlags

curSymbols :: String
curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney :: String -> Maybe Semantics
analyzeMoney str = do
  ms <- match rgx str
  s <- (ms !! 1)
  n <- (s >>= s2n)
  curSymbol <- let fstSymbol = take 1 str
               in if fstSymbol == ""
                  then Nothing
                  else pure fstSymbol

  pure $ Money n curSymbol
  where
  rgx = regex rgxStr noFlags
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""

analyzeDate :: String -> Maybe Semantics
analyzeDate str =
  if test rgx str
  then Just $ Time str
  else Nothing
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$"
  rgx = regex rgxStr noFlags

toSemantics :: Json -> Map JCursor Semantics
toSemantics j = fromList $ L.catMaybes ((traverse analyze) <$> toPrims j)

toSemantics' :: JArray -> Map JCursor (L.List (Maybe Semantics))
toSemantics' arr =
  step initial mapLst
  where
  mapArr = map toSemantics $ reverse arr
  mapLst = L.toList mapArr
  ks = L.toList $ nub $ concat $ map (L.fromList <<< keys) mapArr
  initial = fromList $ map (flip Tuple L.Nil) ks

  step acc L.Nil = acc
  step acc (L.Cons m lst) =
    step (insertOne acc m ks) lst

  insertOne acc m L.Nil = acc
  insertOne acc m (L.Cons k ks') =
    insertOne (update (pure <<< L.Cons (lookup k m)) k acc) m ks'

analyzeJArray :: JArray -> Map JCursor Axis
analyzeJArray arr =
  -- If array has exactly one element return it
  do guard $ length arr == 1
     arr !! 0
  -- If element returned transpose it else take initial array
  # maybe arr transpose
  -- Produce map from JCursor to List of values (Maybe Semantics) for every Json
  # toSemantics'
  -- Check if values of that map can be converted to axes (if can it will be Just)
  # map checkSemantics
  -- Make list of Tuple JCursor (Maybe Axis)
  # toList
  -- lift Maybe to Tuple from Axis
  # map sequence
  -- Drop Nothings
  # L.catMaybes
  -- Create new Map
  # fromList
  -- Drop records those keys have no relations to other keys
  # checkPairs

  where
  transpose :: Json -> JArray
  transpose =
    -- decoding Json it should be a JObject to success
    decodeJson
    -- mapping Either
    -- convert StrMap to list of Tuples
    >>> map (Sm.toList
             -- mapping list
             -- make pair of Tuples from this one. One for key. One for value
             >>> map (tpl2sm
                      -- make StrMap from that pair {key: a, value: b}
                      >>> Sm.fromList
                      -- encode it to json
                      >>> encodeJson))
    -- if decoding to StrMap has no success return empty JArray it will
    -- not produce any Axises. Else convert List of JObjects to Array
    >>> either (const []) L.fromList

  tpl2sm :: Tuple String Json -> L.List (Tuple String Json)
  tpl2sm (Tuple key val) = L.Cons (Tuple "key" $ encodeJson key)
                           $ L.Cons (Tuple "value" val)
                           $ L.Nil

getPossibleDependencies :: JCursor -> Map JCursor Axis -> L.List JCursor
getPossibleDependencies cursor m =
  L.filter (dependsOn cursor) $ keys m

checkPairs :: Map JCursor Axis -> Map JCursor Axis
checkPairs m =
  foldl check m $ keys m
  where
  check :: Map JCursor Axis -> JCursor -> Map JCursor Axis
  check m cursor =
    case getPossibleDependencies cursor m of
      L.Nil -> delete cursor m
      _ -> m

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Model.Notebook.ECharts
  ( analyzeJArray
  , getPossibleDependencies
  , dependsOn
  , isComplement
  , Axis(..)
  , Semantics(..)
  , isValue
  , isPercent
  , isMoney
  , isBool
  , isTime
  , isCategory
  , isValAxis
  , isCatAxis
  , isTimeAxis
  , runAxis
  , catFromSemantics
  , valFromSemantics
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.MonadPlus (guard)
import Data.Argonaut.Core (Json(), JArray(), toNumber, toString)
import Data.Argonaut.JCursor (JCursor(..), JsonPrim(), toPrims, runJsonPrim, insideOut)
import Data.Array (filter, concat, nubBy, singleton, sortBy, head, reverse, length, tail, (!!), (:), nub, elemIndex)
import Data.Bifunctor (rmap)
import Data.Foldable (for_, traverse_, foldl, fold, Foldable)
import Data.Traversable (traverse, sequence)
import Data.Function (on)
import Data.Map (fromList, Map(), toList, empty, alter, insert, keys, lookup, delete, update)
import Data.Maybe (Maybe(..), maybe, isJust, isNothing, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Monoid.Conj (Conj(..), runConj)
import Data.String (take)
import Data.String.Regex (noFlags, regex, match, test)
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat, isNaN)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, jsonEmptyObject, JArray(), Json())
import Data.Either
import Data.Unfoldable (Unfoldable)
import Utils (s2n, s2i)
import qualified Data.List as L
import qualified Data.StrMap as Sm

dependsOn :: JCursor -> JCursor -> Boolean
dependsOn a b = a /= b &&
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

instance encodeJsonSemantics :: EncodeJson Semantics where
  encodeJson (Value n) = "type" := "value"
                         ~> "value" := n
                         ~> jsonEmptyObject

  encodeJson (Percent n) = "type" := "percent"
                           ~> "value" := n
                           ~> jsonEmptyObject

  encodeJson (Money n v) = "type" := "money"
                           ~> "value" := n
                           ~> "currency" := v
                           ~> jsonEmptyObject

  encodeJson (Bool b) = "type" := "bool"
                        ~> "value" := b
                        ~> jsonEmptyObject

  encodeJson (Category c) = "type" := "category"
                            ~> "value" := c
                            ~> jsonEmptyObject

  encodeJson (Time t) = "type" := "time"
                        ~> "value" := t
                        ~> jsonEmptyObject

instance decodeJsonSemantics :: DecodeJson Semantics where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    case ty of
      "money" -> do
        curr <- obj .? "currency"
        m <- obj .? "value"
        pure (Money m curr)
      "time" -> do
        t <- obj .? "value"
        pure $ Time t
      "bool" -> do
        b <- obj .? "value"
        pure $ Bool b
      "category" -> do
        c <- obj .? "value"
        pure $ Category c
      "value" -> do
        v <- obj .? "value"
        pure $ Value v
      "percent" -> do
        p <- obj .? "value"
        pure $ Percent p
      _ -> Left "incorrect type of semanthic"

data Axis
  = ValAxis (L.List (Maybe Semantics))
  | CatAxis (L.List (Maybe Semantics))
  | TimeAxis (L.List (Maybe Semantics))

instance encodeJsonAxis :: EncodeJson Axis where
  encodeJson (ValAxis mbs) = "type" := "val-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (CatAxis mbs) = "type" := "cat-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (TimeAxis mbs) = "type" := "time-axis"
                              ~> "els" := mbs
                              ~> jsonEmptyObject

instance decodeJsonAxis :: DecodeJson Axis where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    mbs <- obj .? "els"
    case ty of
      "val-axis" -> pure $ ValAxis mbs
      "cat-axis" -> pure $ CatAxis mbs
      "time-axis" -> pure $ TimeAxis mbs
      _ -> Left "incorrect axis type"

isValAxis :: Axis -> Boolean
isValAxis (ValAxis _) = true
isValAxis _ = false

isCatAxis :: Axis -> Boolean
isCatAxis (CatAxis _) = true
isCatAxis _ = false

isTimeAxis :: Axis -> Boolean
isTimeAxis (TimeAxis _) = true
isTimeAxis _ = false

runAxis :: Axis -> L.List (Maybe Semantics)
runAxis (ValAxis a) = a
runAxis (CatAxis a) = a
runAxis (TimeAxis a) = a

instance axisShow :: Show Axis where
  show (ValAxis vs) = "(ValAxis " <> show vs <> ")"
  show (CatAxis vs) = "(CatAxis " <> show vs <> ")"
  show (TimeAxis vs) = "(TimeAxis " <> show vs <> ")"

isValue :: Semantics -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semantics -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semantics -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semantics -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semantics -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semantics -> Boolean
isTime (Time _) = true
isTime _ = false

isComplement :: Axis -> Axis -> Boolean
isComplement (CatAxis _) (CatAxis _) = false
isComplement (TimeAxis _) (TimeAxis _) = false
isComplement _ _ = true

catFromSemantics :: Semantics -> Maybe String
catFromSemantics v =
  case v of
    Value v -> pure $ show v
    Percent v -> pure $ show v <> "%"
    Money v m -> pure $ show v <> m
    Category s -> pure s
    Time t -> pure t
    Bool b -> pure $ show b

valFromSemantics :: Semantics -> Maybe Number
valFromSemantics v =
  case v of
    Value v -> pure v
    Money v _ -> pure v
    Percent v -> pure v
    _ -> Nothing

checkSemantics :: L.List (Maybe Semantics) -> Maybe Axis
checkSemantics lst =
  (ValAxis  <$> checkValues lst)   <|>
  (ValAxis  <$> checkMoney lst)    <|>
  (ValAxis  <$> checkPercent lst)  <|>
  (ValAxis  <$> checkBool lst)     <|>
  (TimeAxis <$> checkTime lst)     <|>
  (CatAxis  <$> checkCategory lst)

checkPredicate :: (Semantics -> Boolean) -> L.List (Maybe Semantics) ->
                  Maybe (L.List (Maybe Semantics))
checkPredicate p lst =
  go 0 0 lst L.Nil
  where
  -- traversed. If there is more correct value then incorrect return
  -- list with filtered values. else nothing.
  go correct incorrect L.Nil acc
    | correct > incorrect = Just $ L.reverse acc
    | otherwise = Nothing
  -- There is no value. Just put it to acc don't touch counters
  go correct incorrect (L.Cons Nothing lst) acc =
    go correct incorrect lst (L.Cons Nothing acc)
  -- There is a value
  go correct incorrect (L.Cons (Just c) lst) acc
    -- It means nothing. Put Nothing to accum and don't touch counters
    | isJust $ elemIndex c nothings = go correct incorrect lst (L.Cons Nothing acc)
    -- It's correct. Increase correct counter, put value to accum
    | p c = go (correct + one) incorrect lst (L.Cons (Just c) acc)
    -- It's incorrect. Increase incorrect counter, put nothing to accum
    | otherwise = go correct (incorrect + one) lst (L.Cons Nothing acc)

  nothings :: Array Semantics
  nothings = map Category [ "undefined"
                          , "null"
                          , "NA"
                          , "N/A"
                          ]

checkValues :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkValues = checkPredicate isValue

checkMoney :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkMoney = checkPredicate isMoney

checkPercent :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkPercent = checkPredicate isPercent

checkBool :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkBool = checkPredicate isBool

checkTime :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkTime = checkPredicate isTime

checkCategory :: L.List (Maybe Semantics) -> Maybe (L.List (Maybe Semantics))
checkCategory = checkPredicate isCategory

instance semanthicShow :: Show Semantics where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semantics where
  eq (Value v) (Value v') = v == v'
  eq (Value v) _ = false
  eq (Percent p) (Percent p') = p == p'
  eq (Percent _) _ = false
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Money _ _) _ = false
  eq (Time t) (Time t') = t == t'
  eq (Time _) _ = false
  eq (Category c) (Category c') = c == c'
  eq (Category _) _ = false
  eq (Bool b) (Bool b') = b == b'
  eq (Bool _) _ = false

instance semanthicOrd :: Ord Semantics where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'
  compare (Category _) _ = LT
  compare (Bool b) (Bool b') = compare b b'
  compare (Bool _) _ = LT

analyze :: JsonPrim -> Maybe Semantics
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semantics
analyzeString str =
  (analyzeDate str) <|>
  (analyzeNumber str) <|>
  (analyzeMoney str) <|>
  (analyzePercent str) <|>
  (Just $ Category str)

analyzeNumber :: String -> Maybe Semantics
analyzeNumber s = do
  num <- s2n s
  i <- s2i s
  guard $ show num == s || show i == s
  pure $ Value num

analyzePercent :: String -> Maybe Semantics
analyzePercent input = do
  ms <- match rgx input
  s <- (ms !! 1)
  n <- (s >>= s2n)
  pure $ Percent n
  where rgx = regex """^(-?\d+(\.\d+)?)\%$""" noFlags

curSymbols :: String
curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney :: String -> Maybe Semantics
analyzeMoney str = do
  ms <- match rgx str
  s <- (ms !! 1)
  n <- (s >>= s2n)
  curSymbol <- let fstSymbol = take 1 str
               in if fstSymbol == ""
                  then Nothing
                  else pure fstSymbol

  pure $ Money n curSymbol
  where
  rgx = regex rgxStr noFlags
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""

analyzeDate :: String -> Maybe Semantics
analyzeDate str =
  if test rgx str
  then Just $ Time str
  else Nothing
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$"
  rgx = regex rgxStr noFlags

toSemantics :: Json -> Map JCursor Semantics
toSemantics j = fromList $ L.catMaybes ((traverse analyze) <$> toPrims j)

toSemantics' :: JArray -> Map JCursor (L.List (Maybe Semantics))
toSemantics' arr =
  step initial mapLst
  where
  mapArr = map toSemantics $ reverse arr
  mapLst = L.toList mapArr
  ks = L.toList $ nub $ concat $ map (L.fromList <<< keys) mapArr
  initial = fromList $ map (flip Tuple L.Nil) ks

  step acc L.Nil = acc
  step acc (L.Cons m lst) =
    step (insertOne acc m ks) lst

  insertOne acc m L.Nil = acc
  insertOne acc m (L.Cons k ks') =
    insertOne (update (pure <<< L.Cons (lookup k m)) k acc) m ks'

analyzeJArray :: JArray -> Map JCursor Axis
analyzeJArray arr =
  -- If array has exactly one element return it
  do guard $ length arr == 1
     arr !! 0
  -- If element returned transpose it else take initial array
  # maybe arr transpose
  -- Produce map from JCursor to List of values (Maybe Semantics) for every Json
  # toSemantics'
  -- Check if values of that map can be converted to axes (if can it will be Just)
  # map checkSemantics
  -- Make list of Tuple JCursor (Maybe Axis)
  # toList
  -- lift Maybe to Tuple from Axis
  # map sequence
  -- Drop Nothings
  # L.catMaybes
  -- Create new Map
  # fromList
  -- Drop records those keys have no relations to other keys
  # checkPairs

  where
  transpose :: Json -> JArray
  transpose =
    -- decoding Json it should be a JObject to success
    decodeJson
    -- mapping Either
    -- convert StrMap to list of Tuples
    >>> map (Sm.toList
             -- mapping list
             -- make pair of Tuples from this one. One for key. One for value
             >>> map (tpl2sm
                      -- make StrMap from that pair {key: a, value: b}
                      >>> Sm.fromList
                      -- encode it to json
                      >>> encodeJson))
    -- if decoding to StrMap has no success return empty JArray it will
    -- not produce any Axises. Else convert List of JObjects to Array
    >>> either (const []) L.fromList

  tpl2sm :: Tuple String Json -> L.List (Tuple String Json)
  tpl2sm (Tuple key val) = L.Cons (Tuple "key" $ encodeJson key)
                           $ L.Cons (Tuple "value" val)
                           $ L.Nil

getPossibleDependencies :: JCursor -> Map JCursor Axis -> L.List JCursor
getPossibleDependencies cursor m =
  L.filter (dependsOn cursor) $ keys m

checkPairs :: Map JCursor Axis -> Map JCursor Axis
checkPairs m =
  foldl check m $ keys m
  where
  check :: Map JCursor Axis -> JCursor -> Map JCursor Axis
  check m cursor =
    case getPossibleDependencies cursor m of
      L.Nil -> delete cursor m
      _ -> m