Maybe functioning OutputHandler

Maybe functioning OutputHandler

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row
import Control.Monad.Aff.Bus as Bus
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.List (List, (:))
import Data.Maybe (Maybe(..), Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj, inj)
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

class ConsHandler (rin :: # Type) (rfun :: # Type) (l :: Symbol) a b (rin2 :: # Type) (rfun2 :: # Type)
      | rin l a -> rin2, rfun l a b -> rfun2

instance consHandler
         :: ( RowLacks l rin2
            , RowLacks l rfun2
            , RowCons l a rin1 rin2
            , RowCons l (a -> b) rfun1 rfun2
            )
         => ConsHandler rin rfun l a b rin2 rfun2

class AppendHandlerImpl (rin :: # Type) (rfun :: # Type) (l :: RowList) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil a b rin2 rfun2

instance appendHandlerCons
         :: ConsHandler rin rfun k a b rin2 rfun2
         => AppendHandlerImpl rin rfun (Cons k ty rest) a b rin2 rfun2

class AppendHandler (rin :: # Type) (rfun :: # Type) (l :: # Type) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerInstance
         :: ( RowToList l llist
            , AppendHandlerImpl rin rfun llist a b rin2 rfun2
            )
         => AppendHandler rin rfun ls a b rin2 rfun2

class ConcatHandler (rin1 :: # Type) (rfun1 :: # Type)
                    (rin2 :: # Type) (rfun2 :: # Type)
                    (rin3 :: # Type) (rfun3 :: # Type)
      | rin1 rin2 -> rin3, rfun1 rfun2 -> rfun3
      , rin1 rin3 -> rin2, rfun1 rfun3 -> rfun2
      , rin2 rin3 -> rin1, rfun2 rfun3 -> rfun1

class ConcatHandlerImpl (lin1 :: RowList) (lfun1 :: RowList)
                        (lin2 :: RowList) (lfun2 :: RowList)
                        (lin3 :: RowList) (lfun3 :: RowList)

instance concatHandlerNil :: ConcatHandlerImpl Nil Nil Nil Nil Nil Nil

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun eff.
               Union lt a rin
            => InputHandler rin rfun (Eff (avar :: AVAR | eff) Unit)
            -> BusRW (Variant lt)
            -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val

-- 'a' is the input type; the type of data that this handler can parse
-- 'rout' is the row of types that this can produce
data OutputHandler a (rout :: # Type) = OutputHandler (List (a -> Maybe (Variant rout)))

maybeToVariant :: ∀ l a r.
                  RowCons l a () r
               => IsSymbol l
               => SProxy l
               -> Maybe a
               -> Maybe (Variant r)
maybeToVariant l m = do
  x <- m
  pure $ (inj l x)

maybeFunToVariant :: ∀ l a b r.
                     RowCons l b () r
                  => IsSymbol l
                  => SProxy l
                  -> (a -> Maybe b)
                  -> (a -> Maybe (Variant r))
maybeFunToVariant l f = \a -> do
  x <- f a
  pure $ (inj l x)

maybeFun2 :: ∀ l a b r1 r r2.
             Union r1 r r2
          => RowLacks l r1
          => RowCons l b r1 r2
          => IsSymbol l
          => SProxy l
          -> (a -> Maybe b)
          -> List (a -> Maybe (Variant r1))
          -> List (a -> Maybe (Variant r2))
maybeFun2 l f list = fun2:((map <<< map <<< map) expand list)
  where fun2 :: a -> Maybe (Variant r2)
        fun2 = \a -> do
                x <- f a
                pure $ (inj l x)

appendOutputHandler :: ∀ l a b r1 r r2.
                      Union r1 r r2
                    => RowLacks l r1
                    => RowCons l b r1 r2
                    => IsSymbol l
                    => SProxy l
                    -> (a -> Maybe b)
                    -> OutputHandler a r1
                    -> OutputHandler a r2
appendOutputHandler l f (OutputHandler h) = OutputHandler (maybeFun2 l f h)

emptyOutputHandler :: ∀ a.
                      OutputHandler a ()
emptyOutputHandler = OutputHandler mempty

-- given an input, try _all_ handlers (parsers), and output a list of variants,
-- containing all valid parses.
-- so, actually
-- applyOutputHandler

-- runOutputHandler :: ∀ lt a rout rfun b.
--                     OutputHandler a rout rfun
--                  -> a
--                  -> List (Variant rout)
-- runOutputHandler (OutputHandler h) v = ?help
  -- case coerceV v of
  --   Tuple tag a -> a # unsafeGet tag h
  -- where coerceV :: ∀ c. Variant lt -> Tuple String c
  --       coerceV = unsafeCoerce

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row

import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.List (List)
import Data.Maybe (Maybe, Maybe(..))
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj)
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

class ConsHandler (rin :: # Type) (rfun :: # Type) (l :: Symbol) a b (rin2 :: # Type) (rfun2 :: # Type)
      | rin l a -> rin2, rfun l a b -> rfun2

instance consHandler
         :: ( RowLacks l rin2
            , RowLacks l rfun2
            , RowCons l a rin1 rin2
            , RowCons l (a -> b) rfun1 rfun2
            )
         => ConsHandler rin rfun l a b rin2 rfun2

class AppendHandlerImpl (rin :: # Type) (rfun :: # Type) (l :: RowList) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil a b rin2 rfun2

instance appendHandlerCons
         :: ConsHandler rin rfun k a b rin2 rfun2
         => AppendHandlerImpl rin rfun (Cons k ty rest) a b rin2 rfun2

class AppendHandler (rin :: # Type) (rfun :: # Type) (l :: # Type) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerInstance
         :: ( RowToList l llist
            , AppendHandlerImpl rin rfun llist a b rin2 rfun2
            )
         => AppendHandler rin rfun ls a b rin2 rfun2

class ConcatHandler (rin1 :: # Type) (rfun1 :: # Type)
                    (rin2 :: # Type) (rfun2 :: # Type)
                    (rin3 :: # Type) (rfun3 :: # Type)
      | rin1 rin2 -> rin3, rfun1 rfun2 -> rfun3
      , rin1 rin3 -> rin2, rfun1 rfun3 -> rfun2
      , rin2 rin3 -> rin1, rfun2 rfun3 -> rfun1

class ConcatHandlerImpl (lin1 :: RowList) (lfun1 :: RowList)
                        (lin2 :: RowList) (lfun2 :: RowList)
                        (lin3 :: RowList) (lfun3 :: RowList)

instance concatHandlerNil :: ConcatHandlerImpl Nil Nil Nil Nil Nil Nil

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun eff.
               Union lt a rin
            => InputHandler rin rfun (Eff (avar :: AVAR | eff) Unit)
            -> BusRW (Variant lt)
            -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val

-- 'a' is the input type; the type of data that this handler can parse
-- 'rout' is the row of types that this can produce
-- 'rfun' is the row of types that corresponds to the record with functions
data OutputHandler a (rout :: # Type) (rfun :: # Type) = OutputHandler (Record rfun)

-- appendOutputHandler :: ∀ l a rout1 rout2 rfun1 rfun2.
                    --    RowLacks l rout1
                    -- => RowLacks l rfun1
                    -- => RowCons l (a -> Maybe rout1) rfun1 rfun2
                    -- => RowCons l a rout1 rout2
                    -- => IsSymbol l
                    -- => SProxy l
                    -- -> (a -> Maybe rout1)
                    -- -> OutputHandler rout1 rfun1 a
                    -- -> OutputHandler rout2 rfun2 a
appendOutputHandler :: ∀ l a b rout1 rout2 rfun1 rfun2.
                       RowLacks l rout1
                    => RowLacks l rfun1
                    => RowCons l (a -> Maybe b) rfun1 rfun2
                    => RowCons l b rout1 rout2
                    => IsSymbol l
                    => SProxy l
                    -> (a -> Maybe b)
                    -> OutputHandler a rout1 rfun1
                    -> OutputHandler a rout2 rfun2
appendOutputHandler l f (OutputHandler r) = OutputHandler $ insert l f r

emptyOutputHandler :: ∀ a.
                      OutputHandler a () ()
emptyOutputHandler = OutputHandler {}

runOutputHandler :: ∀ lt a rout rfun b.
                    -- Union lt a rin
                    OutputHandler a rout rfun
                 -> a
                 -> List (Variant rout)
runOutputHandler (OutputHandler h) v = ?help
  -- case coerceV v of
  --   Tuple tag a -> a # unsafeGet tag h
  -- where coerceV :: ∀ c. Variant lt -> Tuple String c
  --       coerceV = unsafeCoerce


CSM-152 fix remove extra slash

CSM-152 fix remove extra slash

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

putRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
putRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left PUT
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

deleteR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
deleteR = makeRequest $ defaultRequest { method = Left DELETE }

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["wallets", _address addr]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = putRBody ["wallets", _address addr]

newWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["wallets"]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets", "keys"]

restoreWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet = postRBody ["wallets", "restore"]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount]

sendExtended :: forall eff. CAddress -> CAddress -> Coin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended addrFrom addrTo amount curr title desc = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount, showCCurrency curr, title, desc]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["txs", "payments", _address addr, _ctxIdValue ctxId]

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs", "histories", _address addr <> "?skip=" <> show skip <> "&limit=" <> show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs", "histories", _address addr, search <> "?skip=" <> show skip <> "&limit=" <> show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
redeemADA = postRBody ["redemptions", "ada"]
--------------------------------------------------------------------------------
-- REPORTING ---------------------------------------------------------------------
reportInit :: forall eff. CInitialized -> Aff (ajax :: AJAX | eff) Unit
reportInit = postRBody ["reporting", "initialized"]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings", "slots", "duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings", "version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings", "sync", "progress"]
--------------------------------------------------------------------------------

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

putRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
putRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left PUT
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

deleteR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
deleteR = makeRequest $ defaultRequest { method = Left DELETE }

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["wallets", _address addr]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = putRBody ["wallets", _address addr]

newWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["wallets"]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets", "keys"]

restoreWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet = postRBody ["wallets", "restore"]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount]

sendExtended :: forall eff. CAddress -> CAddress -> Coin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended addrFrom addrTo amount curr title desc = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount, showCCurrency curr, title, desc]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["txs", "payments", _address addr, _ctxIdValue ctxId]

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs", "histories", _address addr, "?skip=",show skip, "&limit=",show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs", "histories", _address addr, search, "?skip=",show skip, "&limit=",show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
redeemADA = postRBody ["redemptions", "ada"]
--------------------------------------------------------------------------------
-- REPORTING ---------------------------------------------------------------------
reportInit :: forall eff. CInitialized -> Aff (ajax :: AJAX | eff) Unit
reportInit = postRBody ["reporting", "initialized"]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings", "slots", "duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings", "version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings", "sync", "progress"]
--------------------------------------------------------------------------------


Clean up imports

Clean up imports

module Test.Spec.GenSpec (
  genSpec
, genTransSpec
)
where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Gen (genParser, runParser)
import Docopt.Gen.Trans (expand)

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Docopt

type Input = Array String
type Output = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(#=) = Tuple
infixr 0 #=

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ str "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = po     "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ] ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ]
            , eoa       #= array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ]
            , eoa       #= array [ str "--" , str "--" ]
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") #= (str "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= str "bar"
            , opt 'r' "redirect" (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE")   #= str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= str "bar"
            , opt 'r' "redirect" (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE")   #= str "bar" ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , po  "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , po  "env" false               #= str "x"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ cmd_foo          #= bool true
            , opt_o_out        #= bool true
            , opt_i_input      #= bool true
            , opt_q_qux___r    #= array [ bool true ]
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , cmd_baz          #= bool true
            -- should have added default value that was not provided above:
            , opt_b_baz        #= str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ cmd_foo          #= bool true
            , opt_o_out        #= bool true
            , opt_q_qux___r    #= array [ bool true , bool true , bool true ]
            , opt_f_foo_FOZ__r #= array [str "ox"]
            , opt_b_baz        #= str "ax"
            , opt_i_input      #= bool true
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ cmd_foo          #= bool true
            , opt_q_qux___r    #= array [ bool true , bool true ]
            , opt_o_out        #= bool true
            , opt_i_input      #= bool true
            , opt_b_baz        #= str "ax"
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ cmd_foo          #= bool true
            , opt_b_baz        #= str "ax"
            , opt_o_out        #= bool true
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , opt_i_input      #= bool true
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ cmd_foo     #= bool true
            , opt_o_out   #= bool true
            , opt_i_input #= bool true
            , opt_b_baz   #= str "ax"
            , cmd_baz     #= bool true
            -- should have added default value that was not provided above:
            , opt_b_baz   #= str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected

genTransSpec = \_ ->
  describe "The output transformer" do
    it "..." do
      let m = Map.fromList $ toList [
        opt  'i' "input" (oa "BAR" $ str "Foo") #= str "qux"
      , optR 'i' "input" (oa_ "BAR")            #= str "xuq"
      ]
      traceShowA m
      traceShowA (expand m)
      pure unit

module Test.Spec.GenSpec (
  genSpec
, genTransSpec
)
where

import Prelude
import Data.Tuple (Tuple(..))
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException, catchException
                                   , message)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Spec.Parser.Usage (Usage(..))
import qualified Docopt.Spec.Parser.Usage as Usage
import qualified Docopt.Spec.Parser.Lexer as Lexer
import qualified Docopt.Spec.Parser.Scanner as Scanner
import Docopt.Gen (genParser, runParser)
import Docopt.Gen.Trans (expand)
import Docopt.Gen.Lexer (lex)
import Docopt.Spec.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Docopt

type Input = Array String
type Output = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(#=) = Tuple
infixr 0 #=

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ str "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = po     "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ] ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ]
            , eoa       #= array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ pos_arg_r #= array [ str "a" , str "b" , str "c" ]
            , eoa       #= array [ str "--" , str "--" ]
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") #= (str "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= str "bar"
            , opt 'r' "redirect" (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE")   #= str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= str "bar"
            , opt 'r' "redirect" (oa_ "FILE") #= str "bar"
            , opt 'o' "output" (oa_ "FILE")   #= str "bar" ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , po  "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= str "bar"
            , po  "env" false               #= str "x"
            , opt 'o' "output" (oa_ "FILE") #= str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ cmd_foo          #= bool true
            , opt_o_out        #= bool true
            , opt_i_input      #= bool true
            , opt_q_qux___r    #= array [ bool true ]
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , cmd_baz          #= bool true
            -- should have added default value that was not provided above:
            , opt_b_baz        #= str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ cmd_foo          #= bool true
            , opt_o_out        #= bool true
            , opt_q_qux___r    #= array [ bool true , bool true , bool true ]
            , opt_f_foo_FOZ__r #= array [str "ox"]
            , opt_b_baz        #= str "ax"
            , opt_i_input      #= bool true
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ cmd_foo          #= bool true
            , opt_q_qux___r    #= array [ bool true , bool true ]
            , opt_o_out        #= bool true
            , opt_i_input      #= bool true
            , opt_b_baz        #= str "ax"
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ cmd_foo          #= bool true
            , opt_b_baz        #= str "ax"
            , opt_o_out        #= bool true
            , opt_f_foo_FOZ__r #= array [ str "ox" ]
            , opt_i_input      #= bool true
            , cmd_baz          #= bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ cmd_foo     #= bool true
            , opt_o_out   #= bool true
            , opt_i_input #= bool true
            , opt_b_baz   #= str "ax"
            , cmd_baz     #= bool true
            -- should have added default value that was not provided above:
            , opt_b_baz   #= str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected

genTransSpec = \_ ->
  describe "The output transformer" do
    it "..." do
      let m = Map.fromList $ toList [
        opt  'i' "input" (oa "BAR" $ str "Foo") #= str "qux"
      , optR 'i' "input" (oa_ "BAR")            #= str "xuq"
      ]
      traceShowA m
      traceShowA (expand m)
      pure unit


Tidier

Tidier

Original commit 771ad28f51e90c191280a7097d3033b3b23ae2e0

module CSharp
    ( renderCSharpClass
    ) where

import Doc
import IR
import Prelude

import Data.Foldable (for_, intercalate)
import Data.Map as Map
import Data.Set as Set
import Data.Tuple as Tuple

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass { name } -> name
    IRUnion types -> "Either<" <> intercalate ", " (Set.map renderTypeToCSharp types) <> ">"

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> line do
            string "public "
            string $ renderTypeToCSharp ptype
            words ["", pname, "{ get; set; }"]
    line "}"

module CSharp
    ( renderCSharpClass
    ) where

import Prelude

import IR
import Doc

import Data.Foldable (for_)
import Data.Tuple as Tuple
import Data.Map as Map
import Data.String as String
import Data.Array as Array

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass { name } -> name
    IRUnion types -> "Either<" <> String.joinWith ", " (map renderTypeToCSharp (Array.fromFoldable types)) <> ">"

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> line do
            string "public "
            string $ renderTypeToCSharp ptype
            words ["", pname, "{ get; set; }"]
    line "}"


Remove unnecessary import (#26)

Remove unnecessary import (#26)

module HTTPure.HTTPureM
  ( HTTPureM
  ) where

import Control.Monad.Eff as Eff
import Node.HTTP as HTTP

-- | The `HTTPureM` monad represents effects run by an HTTPure server. It takes
-- | an effects row parameter which enumerates all other side-effects performed
-- | while carrying out the server actions.
type HTTPureM e t = Eff.Eff (http :: HTTP.HTTP | e) t

module HTTPure.HTTPureM
  ( HTTPureM
  ) where

import Prelude (Unit)

import Control.Monad.Eff as Eff
import Node.HTTP as HTTP

-- | The `HTTPureM` monad represents effects run by an HTTPure server. It takes
-- | an effects row parameter which enumerates all other side-effects performed
-- | while carrying out the server actions.
type HTTPureM e t = Eff.Eff (http :: HTTP.HTTP | e) t


Print number of tests that were ran

Print number of tests that were ran

module Test.QuickCheck where

import Prelude
import Data.Array
import Data.Maybe
import Data.Either
import Data.Tuple
import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Random

data Result = Success | Failed String

type QC = forall eff. Eff (random :: Random, trace :: Trace, err :: Exception String | eff) {}

class Arb t where
  arb :: forall eff. Eff (random :: Random | eff) t

instance arbNumber :: Arb Number where
  arb = random

instance arbBoolean :: Arb Boolean where
  arb = do
    n <- random
    return ((n * 2) < 1)

instance arbArray :: (Arb a) => Arb [a] where
  arb = do
    b <- arb
    if b then return [] else do
      a <- arb
      as <- arb
      return (a : as)

instance arbMaybe :: (Arb a) => Arb (Maybe a) where
  arb = do
    b <- arb
    if b then pure Nothing else Just <$> arb

instance arbEither :: (Arb a, Arb b) => Arb (Either a b) where
  arb = do
    b <- arb
    if b then Left <$> arb else Right <$> arb

instance arbTuple :: (Arb a, Arb b) => Arb (Tuple a b) where
  arb = Tuple <$> arb <*> arb

class Testable prop where
  test :: forall eff. prop -> Eff (random :: Random | eff) Result

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Show t, Arb t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arb
    result <- test (f t)
    case result of
      Success -> return Success
      Failed msg -> return $ Failed $ "Failed on input " ++ show t ++ ": \n" ++ msg

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC
quickCheck' n prop = run n prop n
  where
  run 2 _ 1 = trace $ "Test passed"
  run n _ t | n == t = trace $ show t ++ " tests passed"
  run n prop t = do
    result <- test prop
    case result of
      Success -> run (n + 1) prop t
      Failed msg -> throwException $ "Test failed: \n" ++ msg

quickCheck :: forall prop. (Testable prop) => prop -> QC
quickCheck prop = quickCheck' 100 prop

module Test.QuickCheck where

import Prelude
import Data.Array
import Data.Maybe
import Data.Either
import Data.Tuple
import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Random

data Result = Success | Failed String

type QC = forall eff. Eff (random :: Random, trace :: Trace, err :: Exception String | eff) {}

class Arb t where
  arb :: forall eff. Eff (random :: Random | eff) t

instance arbNumber :: Arb Number where
  arb = random

instance arbBoolean :: Arb Boolean where
  arb = do
    n <- random
    return ((n * 2) < 1)

instance arbArray :: (Arb a) => Arb [a] where
  arb = do
    b <- arb
    if b then return [] else do
      a <- arb
      as <- arb
      return (a : as)

instance arbMaybe :: (Arb a) => Arb (Maybe a) where
  arb = do
    b <- arb
    if b then pure Nothing else Just <$> arb

instance arbEither :: (Arb a, Arb b) => Arb (Either a b) where
  arb = do
    b <- arb
    if b then Left <$> arb else Right <$> arb

instance arbTuple :: (Arb a, Arb b) => Arb (Tuple a b) where
  arb = Tuple <$> arb <*> arb

class Testable prop where
  test :: forall eff. prop -> Eff (random :: Random | eff) Result

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Show t, Arb t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arb
    result <- test (f t)
    case result of
      Success -> return Success
      Failed msg -> return $ Failed $ "Failed on input " ++ show t ++ ": \n" ++ msg

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC
quickCheck' 0 _ = trace "All tests passed"
quickCheck' n prop = do
  result <- test prop
  case result of
    Success -> quickCheck' (n - 1) prop
    Failed msg -> throwException $ "Test failed: \n" ++ msg

quickCheck :: forall prop. (Testable prop) => prop -> QC
quickCheck prop = quickCheck' 100 prop


Fix explore card eval loop

Fix explore card eval loop

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.OpenResource.Component
  ( openResourceComponent
  , module SlamData.Workspace.Card.OpenResource.Component.Query
  , module SlamData.Workspace.Card.OpenResource.Component.State
  ) where

import SlamData.Prelude

import Data.Array as Arr
import Data.Lens as Lens
import Data.Lens ((?~), (.~), (%~))
import Data.Path.Pathy (printPath, peel)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.FS as Quasar
import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.OpenResource.Component.Query (QueryP, Query(..))
import SlamData.Workspace.Card.OpenResource.Component.State (State, initialState, _selected, _browsing, _items, _levelOfDetails)
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type HTML = H.ComponentHTML QueryP
type DSL = H.ComponentDSL State QueryP Slam

openResourceComponent ∷ Maybe R.Resource → H.Component CC.CardStateP CC.CardQueryP Slam
openResourceComponent mres =
  CC.makeCardComponent
    { cardType: CT.OpenResource
    , component: H.lifecycleComponent
        { render
        , eval
        , initializer: Just (H.action (right ∘ Init mres))
        , finalizer: Nothing
        }
    , initialState: initialState { selected = Lens.preview Lens._Right ∘ R.getPath =<< mres  }
    , _State: CC._OpenResourceState
    , _Query: CC.makeQueryPrism CC._OpenResourceQuery
    }

render ∷ State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderLowLOD ∷ State → HTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ (B.hidden <$ guard (state.levelOfDetails ≠ Low))
        ⊕ [ HH.className "card-input-minimum-lod" ]
    ]
    [ HH.button
        [ ARIA.label "Zoom or resize"
        , HP.title "Zoom or resize"
        , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
        ]
        [ glyph B.glyphiconFolderOpen
        , HH.text "Zoom or resize"
        ]
    ]

renderHighLOD ∷ State → HTML
renderHighLOD state =
  HH.div
    [ HP.classes
         $ [ HH.className "card-input-maximum-lod" ]
         ⊕ (B.hidden <$ guard (state.levelOfDetails ≠ High))
    ]
    [ HH.div [ HP.classes [ RC.openResourceCardMenu ] ]
      [ HH.button
          ([ HP.class_ RC.formButton
           ] ⊕ case parentDir of
                Nothing →
                  [ HP.disabled true ]
                Just r →
                  [ HE.onClick (HE.input_ (right ∘ (ResourceSelected r)))
                  , HP.title "Up a directory"
                  , ARIA.label "Up a directory"
                  ]
          )
          [ glyphForDeselectOrUp ]
      , HH.p
          [ ARIA.label $ "Selected resource: " ⊕ selectedLabel ]
          [ HH.text selectedLabel ]
      ]
    , HH.ul_ $ map renderItem state.items
    ]

  where
  glyphForDeselectOrUp ∷ HTML
  glyphForDeselectOrUp | isJust state.selected = glyph B.glyphiconRemove
  glyphForDeselectOrUp | otherwise = glyph B.glyphiconChevronUp

  selectedLabel ∷ String
  selectedLabel =
    fromMaybe ""
    $ map printPath state.selected
    <|> (pure $ printPath state.browsing)

  parentDir ∷ Maybe R.Resource
  parentDir =
    R.Directory
    <$> ((state.selected $> state.browsing)
         <|> (fst <$> peel state.browsing))

  renderItem ∷ R.Resource → HTML
  renderItem r =
    HH.li
      [ HP.classes
          $ ((guard (Just (R.getPath r) ≡ (Right <$> state.selected))) $> B.active)
          ⊕ ((guard (R.hiddenTopLevel r)) $> RC.itemHidden)
      , HE.onClick (HE.input_ (right ∘ ResourceSelected r))
      , ARIA.label labelTitle

      ]
      [ HH.a
          [ HP.title labelTitle ]
          [ glyphForResource r
          , HH.text $ R.resourceName r
          ]
      ]
    where
    labelTitle ∷ String
    labelTitle =
      "Select " ⊕ R.resourcePath r

glyphForResource ∷ R.Resource → HTML
glyphForResource = case _ of
  R.File _ → glyph B.glyphiconFile
  R.Workspace _ → glyph B.glyphiconBook
  R.Directory _ → glyph B.glyphiconFolderOpen
  R.Mount (R.Database _) → glyph B.glyphiconHdd
  R.Mount (R.View _) → glyph B.glyphiconFile

eval ∷ QueryP ~> DSL
eval = cardEval ⨁ openResourceEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.EvalCard info output next →
    pure next
  CC.Save k → do
    mbRes ← H.gets _.selected
    k ∘ Card.OpenResource <$>
      case mbRes of
        Just res → pure ∘ Just $ R.File res
        Nothing → do
          br ← H.gets _.browsing
          pure ∘ Just $ R.Directory br
  CC.Load card next → do
    case card of
      Card.OpenResource (Just (res @ R.File _)) → resourceSelected res
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ (_levelOfDetails
         .~ if dims.width < 288.0 ∨ dims.height < 240.0
              then Low
              else High)
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

openResourceEval ∷ Query ~> DSL
openResourceEval (ResourceSelected r next) = do
  resourceSelected r
  CC.raiseUpdatedC' CC.EvalModelUpdate
  pure next
openResourceEval (Init mres next) = do
  updateItems *> rearrangeItems
  traverse_ resourceSelected mres
  pure next

resourceSelected ∷ R.Resource → DSL Unit
resourceSelected r = do
  case R.getPath r of
    Right fp → do
      for_ (fst <$> peel fp) \dp → do
        oldBrowsing ← H.gets _.browsing
        unless (oldBrowsing ≡ dp) do
          H.modify (_browsing .~ dp)
          updateItems
      H.modify (_selected ?~ fp)
    Left dp → do
      H.modify
        $ (_browsing .~ dp)
        ∘ (_selected .~ Nothing)
      updateItems
  rearrangeItems

updateItems ∷ DSL Unit
updateItems = do
  cs ← Quasar.children =<< H.gets _.browsing
  mbSel ← H.gets _.selected
  H.modify (_items .~ foldMap id cs)

rearrangeItems ∷ DSL Unit
rearrangeItems = do
  H.modify $ _items %~ Arr.sortBy sortFn
  where
  sortFn ∷ R.Resource → R.Resource → Ordering
  sortFn a b
    | R.hiddenTopLevel a && R.hiddenTopLevel b = compare a b
    | R.hiddenTopLevel a = GT
    | R.hiddenTopLevel b = LT
    | otherwise = compare a b

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.OpenResource.Component
  ( openResourceComponent
  , module SlamData.Workspace.Card.OpenResource.Component.Query
  , module SlamData.Workspace.Card.OpenResource.Component.State
  ) where

import SlamData.Prelude

import Data.Array as Arr
import Data.Lens as Lens
import Data.Lens ((?~), (.~), (%~))
import Data.Path.Pathy (printPath, peel)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.FS as Quasar
import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.OpenResource.Component.Query (QueryP, Query(..))
import SlamData.Workspace.Card.OpenResource.Component.State (State, initialState, _selected, _browsing, _items, _levelOfDetails)
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type HTML = H.ComponentHTML QueryP
type DSL = H.ComponentDSL State QueryP Slam

openResourceComponent ∷ Maybe R.Resource → H.Component CC.CardStateP CC.CardQueryP Slam
openResourceComponent mres =
  CC.makeCardComponent
    { cardType: CT.OpenResource
    , component: H.lifecycleComponent
        { render
        , eval
        , initializer: Just (H.action (right ∘ Init mres))
        , finalizer: Nothing
        }
    , initialState: initialState { selected = Lens.preview Lens._Right ∘ R.getPath =<< mres  }
    , _State: CC._OpenResourceState
    , _Query: CC.makeQueryPrism CC._OpenResourceQuery
    }

render ∷ State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderLowLOD ∷ State → HTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ (B.hidden <$ guard (state.levelOfDetails ≠ Low))
        ⊕ [ HH.className "card-input-minimum-lod" ]
    ]
    [ HH.button
        [ ARIA.label "Zoom or resize"
        , HP.title "Zoom or resize"
        , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
        ]
        [ glyph B.glyphiconFolderOpen
        , HH.text "Zoom or resize"
        ]
    ]

renderHighLOD ∷ State → HTML
renderHighLOD state =
  HH.div
    [ HP.classes
         $ [ HH.className "card-input-maximum-lod" ]
         ⊕ (B.hidden <$ guard (state.levelOfDetails ≠ High))
    ]
    [ HH.div [ HP.classes [ RC.openResourceCardMenu ] ]
      [ HH.button
          ([ HP.class_ RC.formButton
           ] ⊕ case parentDir of
                Nothing →
                  [ HP.disabled true ]
                Just r →
                  [ HE.onClick (HE.input_ (right ∘ (ResourceSelected r)))
                  , HP.title "Up a directory"
                  , ARIA.label "Up a directory"
                  ]
          )
          [ glyphForDeselectOrUp ]
      , HH.p
          [ ARIA.label $ "Selected resource: " ⊕ selectedLabel ]
          [ HH.text selectedLabel ]
      ]
    , HH.ul_ $ map renderItem state.items
    ]

  where
  glyphForDeselectOrUp ∷ HTML
  glyphForDeselectOrUp | isJust state.selected = glyph B.glyphiconRemove
  glyphForDeselectOrUp | otherwise = glyph B.glyphiconChevronUp

  selectedLabel ∷ String
  selectedLabel =
    fromMaybe ""
    $ map printPath state.selected
    <|> (pure $ printPath state.browsing)

  parentDir ∷ Maybe R.Resource
  parentDir =
    R.Directory
    <$> ((state.selected $> state.browsing)
         <|> (fst <$> peel state.browsing))

  renderItem ∷ R.Resource → HTML
  renderItem r =
    HH.li
      [ HP.classes
          $ ((guard (Just (R.getPath r) ≡ (Right <$> state.selected))) $> B.active)
          ⊕ ((guard (R.hiddenTopLevel r)) $> RC.itemHidden)
      , HE.onClick (HE.input_ (right ∘ ResourceSelected r))
      , ARIA.label labelTitle

      ]
      [ HH.a
          [ HP.title labelTitle ]
          [ glyphForResource r
          , HH.text $ R.resourceName r
          ]
      ]
    where
    labelTitle ∷ String
    labelTitle =
      "Select " ⊕ R.resourcePath r

glyphForResource ∷ R.Resource → HTML
glyphForResource = case _ of
  R.File _ → glyph B.glyphiconFile
  R.Workspace _ → glyph B.glyphiconBook
  R.Directory _ → glyph B.glyphiconFolderOpen
  R.Mount (R.Database _) → glyph B.glyphiconHdd
  R.Mount (R.View _) → glyph B.glyphiconFile

eval ∷ QueryP ~> DSL
eval = cardEval ⨁ openResourceEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.EvalCard info output next →
    pure next
  CC.Save k → do
    mbRes ← H.gets _.selected
    k ∘ Card.OpenResource <$>
      case mbRes of
        Just res → pure ∘ Just $ R.File res
        Nothing → do
          br ← H.gets _.browsing
          pure ∘ Just $ R.Directory br
  CC.Load card next → do
    case card of
      Card.OpenResource (Just (res @ R.File _)) → resourceSelected res
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ (_levelOfDetails
         .~ if dims.width < 288.0 ∨ dims.height < 240.0
              then Low
              else High)
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

openResourceEval ∷ Query ~> DSL
openResourceEval (ResourceSelected r next) = do
  resourceSelected r
  pure next
openResourceEval (Init mres next) = do
  updateItems *> rearrangeItems
  traverse_ resourceSelected mres
  pure next

resourceSelected ∷ R.Resource → DSL Unit
resourceSelected r = do
  case R.getPath r of
    Right fp → do
      for_ (fst <$> peel fp) \dp → do
        oldBrowsing ← H.gets _.browsing
        unless (oldBrowsing ≡ dp) do
          H.modify (_browsing .~ dp)
          updateItems
      H.modify (_selected ?~ fp)
      CC.raiseUpdatedC' CC.EvalModelUpdate
    Left dp → do
      H.modify
        $ (_browsing .~ dp)
        ∘ (_selected .~ Nothing)
      updateItems
  rearrangeItems

updateItems ∷ DSL Unit
updateItems = do
  dp ← H.gets _.browsing
  cs ← Quasar.children dp
  mbSel ← H.gets _.selected
  H.modify (_items .~ foldMap id cs)

rearrangeItems ∷ DSL Unit
rearrangeItems = do
  H.modify $ _items %~ Arr.sortBy sortFn
  where
  sortFn ∷ R.Resource → R.Resource → Ordering
  sortFn a b | R.hiddenTopLevel a && R.hiddenTopLevel b = compare a b
  sortFn a b | R.hiddenTopLevel a = GT
  sortFn a b | R.hiddenTopLevel b = LT
  sortFn a b = compare a b


Removed any use of Control.Monad.Eff.Console

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


complete table for exped-resource-per-hr

module KanColle.Expedition.New.Config
  ( Config
  , mkConfig
  , defConfig
  , defConfigs
  , getCompositionWithConfig
  , calcFleetActualCostTable
  , calcFleetNetIncomeTable
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.Types
import KanColle.Expedition.New.MinCompo
import KanColle.Expedition.New.CostModel
import KanColle.Expedition.New.NetIncome
import KanColle.Expedition.New.Resource
import KanColle.Expedition.New.EArray
import KanColle.Expedition.New.Info
import KanColle.Expedition.New.Scorer
import Data.Array as A
import Data.Unfoldable
import Data.Traversable

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConfig :: Boolean -> Int -> SType -> Config
mkConfig gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConfig false 0 DD

defConfigs :: EArray Config
defConfigs = mkEA (replicate 40 defConfig)

getCompositionWithConfig :: Config -> Int -> FleetCompo
getCompositionWithConfig (Conf c) n = if c.greatSuccess
    then compo <> replicate (6 - l) c.wildcardSType
    else compo
  where
    minCompo = getMinimumComposition n
    compo = map (fromMaybe c.wildcardSType) minCompo
    l = A.length compo

calcFleetActualCostTable :: EArray Config -> CostModel -> Maybe (EArray FleetActualCost)
calcFleetActualCostTable configs cm = imapEA f <$> mExpedMaxCosts
  where
    concreteCompos :: EArray FleetCompo
    concreteCompos = imapEA (flip getCompositionWithConfig) configs
    mExpedMaxCosts :: Maybe (EArray FleetMaxCost)
    mExpedMaxCosts =
        sequence (map (calcFleetMaxCost cm) concreteCompos)
    f eId maxCost = calcFleetActualCost maxCost (getInformation eId)

calcFleetNetIncomeTable :: EArray Config -> CostModel -> Maybe (EArray FleetNetIncome)
calcFleetNetIncomeTable configs cm = imapEA f <$> mACostTable
  where
    mACostTable :: Maybe (EArray FleetActualCost)
    mACostTable = calcFleetActualCostTable configs cm

    f :: Int -> FleetActualCost -> FleetNetIncome
    f eId = calcFleetNetIncome (getResource eId)

calcResourcePerHrTable :: EArray Config -> CostModel -> Int -> Maybe (EArray ResourcePerHr)
calcResourcePerHrTable configs cm afkTimeInMin = do
    netIncomeTbl <- calcFleetNetIncomeTable configs cm
    let rphTbl =
          imapEA (\eId ni ->
                   calcResourcePerHr ni (getInformation eId) afkTimeInMin)
                 netIncomeTbl
    pure rphTbl

module KanColle.Expedition.New.Config
  ( Config
  , mkConfig
  , defConfig
  , defConfigs
  , getCompositionWithConfig
  , calcFleetActualCostTable
  , calcFleetNetIncomeTable
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.Types
import KanColle.Expedition.New.MinCompo
import KanColle.Expedition.New.CostModel
import KanColle.Expedition.New.NetIncome
import KanColle.Expedition.New.Resource
import KanColle.Expedition.New.EArray
import KanColle.Expedition.New.Info
import Data.Array as A
import Data.Unfoldable
import Data.Traversable

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConfig :: Boolean -> Int -> SType -> Config
mkConfig gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConfig false 0 DD

defConfigs :: EArray Config
defConfigs = mkEA (replicate 40 defConfig)

getCompositionWithConfig :: Config -> Int -> FleetCompo
getCompositionWithConfig (Conf c) n = if c.greatSuccess
    then compo <> replicate (6 - l) c.wildcardSType
    else compo
  where
    minCompo = getMinimumComposition n
    compo = map (fromMaybe c.wildcardSType) minCompo
    l = A.length compo

calcFleetActualCostTable :: EArray Config -> CostModel -> Maybe (EArray FleetActualCost)
calcFleetActualCostTable configs cm = imapEA f <$> mExpedMaxCosts
  where
    concreteCompos :: EArray FleetCompo
    concreteCompos = imapEA (flip getCompositionWithConfig) configs
    mExpedMaxCosts :: Maybe (EArray FleetMaxCost)
    mExpedMaxCosts =
        sequence (map (calcFleetMaxCost cm) concreteCompos)
    f eId maxCost = calcFleetActualCost maxCost (getInformation eId)

calcFleetNetIncomeTable :: EArray Config -> CostModel -> Maybe (EArray FleetNetIncome)
calcFleetNetIncomeTable configs cm = imapEA f <$> mACostTable
  where
    mACostTable :: Maybe (EArray FleetActualCost)
    mACostTable = calcFleetActualCostTable configs cm

    f :: Int -> FleetActualCost -> FleetNetIncome
    f eId = calcFleetNetIncome (getResource eId)