Don't check ready state

Don't check ready state

Just wait with setting the connection until the openHandler got called.

(Checking ready state throws exceptions!)

module Servant.Subscriber.Internal where

import Prelude
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Var as Var
import Control.Monad.ST as ST
import DOM.HTML.Event.ErrorEvent as ErrorEvent
import DOM.Websocket.Event.CloseEvent as CloseEvent
import Data.List as List
import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Servant.Subscriber.Response as Resp
import WebSocket as WS
import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, catchException)
import Control.Monad.Eff.Ref (Ref, REF, modifyRef, readRef, writeRef)
import DOM.Event.Types (keyboardEventToEvent, Event)
import DOM.Websocket.Event.Types (CloseEvent, MessageEvent)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Printer (printJson)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_, sequence_, elem, intercalate, foldl)
import Data.Function.Uncurried (Fn4)
import Data.Generic (gShow, gEq, gCompare, class Generic)
import Data.Lens ((^.), view, prism, (.~), _Just, _2)
import Data.Lens.At (at)
import Data.Lens.Lens (lens)
import Data.Lens.Types (PrismP, LensP)
import Data.List (List, filter)
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (thawST, pureST, StrMap)
import Data.StrMap.ST (STStrMap)
import Data.Tuple (Tuple(Tuple), fst)
import Partial.Unsafe (unsafeCrashWith)
import Servant.PureScript.Util (reportError)
import Servant.Subscriber.Request (HttpRequest(HttpRequest), Request(Subscribe, Unsubscribe, SetPongRequest, SetCloseRequest))
import Servant.Subscriber.Response (HttpResponse)
import Servant.Subscriber.Types (Path(Path))
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET, Message(Message), ReadyState(Open), newWebSocket)
import Data.StrMap.ST.Unsafe as ST

type SubscriberEff eff = Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff)

type Orders a = StrMap (Order a)

type Connection eff a = {
    orders       :: Ref (Orders a)
  , url          :: WS.URL
  , callback     ::  a -> SubscriberEff eff Unit
  , notify       ::  Notification -> SubscriberEff eff Unit
  , connection   :: Ref (Maybe WS.Connection)
  , pongRequest  :: Ref (Maybe HttpRequest)
  , closeRequest :: Ref (Maybe HttpRequest)
  }

type OrderKey = String

makeOrderKey :: HttpRequest -> OrderKey
makeOrderKey = gShow

-- | Information about a subscription:
--   What to subscribe and whom to respond to.
type Subscription a = {
    req :: HttpRequest
  , parseResponses :: List (ToUserType a)
  }

data Notification = WebSocketError String
           | WebSocketClosed String
           | HttpRequestFailed HttpRequest HttpResponse
           | ParseError String -- |< Server response could not be parsed/ Server could not parse our request.

derive instance genericNotification :: Generic Notification

-- | Convert a json modified response to a user specified sum type.
--   The given parameter is 'Nothing' on a Deleted event.
type ToUserType a = Maybe Json -> Either String a

data SubscriptionState = Ordered | Sent | Confirmed

derive instance eqSubscriptionState :: Eq SubscriptionState

type Order a = {
    req :: Request
  , parseResponses :: List (ToUserType a)
  , state :: SubscriptionState
  }

req :: forall r a. LensP ({ req :: a | r}) a
req = lens _.req (\r -> r { req = _ })

state :: forall r a. LensP ({ state :: a | r}) a
state = lens _.state (\r -> r { state = _ })

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

-- | Call this function to actually send requests to the server.
realize :: forall eff a. Connection eff a -> SubscriberEff eff Unit
realize impl = do
      mc <- readRef impl.connection
      case mc of
          Nothing -> makeConnection impl
          Just c ->  sendRequests c impl

-- | Takes care of actually subscribing stuff.
sendRequests :: forall eff a. WS.Connection -> Connection eff a -> SubscriberEff eff Unit
sendRequests (WS.Connection conn) impl = do
      ordered <- List.filter ((_ == Ordered) <<< _.state) <<< StrMap.values <$> Ref.readRef impl.orders
      let
        mkMsg :: Request -> Message
        mkMsg = Message <<< printJson <<< encodeJson

        msgs = map (mkMsg <<< _.req) ordered

      sequence_ $ map conn.send msgs
    --  modifyRef impl.subscriptions $ over (mapped <<< state <<< match Requested) (const Sent) -- Does not work currently.
    --  modifyRef impl.subscriptions $ traverse <<< state <<< filtered (_ == Ordered) .~ Sent -- Does not work currently
      modifyRef impl.orders $ map (\sub -> if sub.state == Ordered then sub { state = Sent } else sub)

initConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
initConnection impl = do
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> makeConnection impl
        Just _ -> pure unit

makeConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
makeConnection impl = do
      WS.Connection conn <- newWebSocket impl.url []
      Var.set conn.onclose   $ closeHandler impl
      Var.set conn.onmessage $ messageHandler impl
      Var.set conn.onerror   $ errorHandler impl
      Var.set conn.onopen    $ openHandler (WS.Connection conn) impl

openHandler :: forall eff a. WS.Connection -> Connection eff a -> Event -> SubscriberEff eff Unit
openHandler conn impl _ = do
  writeRef impl.connection $ Just conn
  sendRequests conn impl

closeHandler :: forall eff a. Connection eff a -> CloseEvent -> SubscriberEff eff Unit
closeHandler impl ev = do
      writeRef impl.connection Nothing
      subs <- readRef impl.orders
      if StrMap.isEmpty subs
        then pure unit
        else do
          modifyRef impl.orders $ updateSubscriptions
          makeConnection impl
      impl.notify $ WebSocketClosed ("code: " <> (show <<< CloseEvent.code) ev <> ", reason: " <> CloseEvent.reason ev)
  where
    isUnsubscribe :: Request -> Boolean
    isUnsubscribe (Unsubscribe _) = true
    isUnsubscribe _ = false

    updateSubscriptions :: Orders a -> Orders a
    updateSubscriptions subs = let
          forRemoval = map fst <<< List.filter (isUnsubscribe <<< view (_2 <<< req)) <<< StrMap.toList $ subs
          cleanedSubs = foldl (flip StrMap.delete) subs forRemoval
        in
          map ( _ { state = Ordered } ) cleanedSubs

errorHandler :: forall eff a. Connection eff a -> Event -> SubscriberEff eff Unit
errorHandler impl ev = do
      impl.notify $ WebSocketError ((ErrorEvent.message <<< unsafeCoerce) ev)
      realize impl -- Something went wrong - retry. (TODO: Probably better with some timeout!)

messageHandler :: forall eff a. Connection eff a -> MessageEvent -> SubscriberEff eff Unit
messageHandler impl msgEvent =  do
      let msg = WS.runMessage <<< WS.runMessageEvent $ msgEvent
      let eDecoded = decodeJson <=< jsonParser $ msg
      case eDecoded of
        Left err -> impl.notify $ ParseError (err <> ", input: '" <> msg <> "'")
        Right resp -> do
            modifyRef impl.orders $ case resp of
                Resp.Subscribed req'          -> onlyIfSent req' $ \key -> at key <<< _Just <<< state .~ Confirmed
                Resp.Deleted path             -> handleDelete path
                Resp.Unsubscribed req'        -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.Modified _ _             -> id
                Resp.HttpRequestFailed req' _ -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.ParseError               -> id
            orders' <- readRef impl.orders
            case resp of
              Resp.Modified req' val            -> doCallback req' (Just val) impl
              Resp.Deleted  path                -> traverse_ (\order' -> doCallback (getHttpReq order'.req) Nothing impl)
                                                   $ getOrdersByPath path orders'
              Resp.HttpRequestFailed req' resp' -> impl.notify $ HttpRequestFailed req' resp'
              Resp.ParseError                   -> impl.notify $ ParseError "Server could not parse our request!"
              Resp.Subscribed _                 -> pure unit
              Resp.Unsubscribed _               -> pure unit

-- | Only update our orders from messageHandler if state is still `Sent` to avoid overriding of more recent user requests.
onlyIfSent :: forall a. HttpRequest -> (OrderKey -> Orders a -> Orders a) -> Orders a -> Orders a
onlyIfSent req' action orders' =
  let
    key = makeOrderKey req'
    order' = orders' ^. at key
  in
   case (_.state) <$> order' of
     Just Sent -> action key orders'
     _    -> orders'

handleDelete :: forall a. Path -> Orders a -> Orders a
handleDelete p = StrMap.fromList <<< filter canStay <<< StrMap.toList
  where
    canStay :: Tuple String (Order a) -> Boolean
    canStay (Tuple _ order) = let req' = runHttpRequest $ getHttpReq order.req
                              in
                               (not <<< eqPath) req'.httpPath p || order.state /= Confirmed -- Only delete if already successfully subscribed!

getOrdersByPath :: forall a. Path -> Orders a -> List (Order a)
getOrdersByPath path = filter (eqPath path <<< getPath <<< _.req) <<< StrMap.values

doCallback :: forall eff a. HttpRequest -> Maybe String -> Connection eff a -> SubscriberEff eff Unit
doCallback req' res impl = do
  orders' <- readRef impl.orders
  let
    order' = case StrMap.lookup (makeOrderKey req') orders' of
      Nothing -> unsafeCrashWith $ "Received a message for an unregistered handler: " <> gShow req'
      Just o -> o
    parsers = order'.parseResponses
    eitherVals :: List (Either String a)
    eitherVals = case res of
      Nothing ->  map (_ $ Nothing) parsers
      Just str -> flip doDecode str <$> parsers
    handleEitherVal :: Either String a -> SubscriberEff eff Unit
    handleEitherVal eitherVal =case eitherVal of
      Right decoded -> impl.callback decoded
      Left err -> impl.notify $ ParseError err
  traverse_ handleEitherVal eitherVals

doDecode :: forall a. ToUserType a -> String -> Either String a
doDecode parser str = do
      jVal <- lmap (reportError id str <<< ("Parsing json response failed: " <> _))
              <<< jsonParser $ str
      parser $ Just jVal

-- | Prism for only setting a value if it is equal to a.
match :: forall a. Eq a => a -> PrismP a a
match a = prism id $ \b -> if a == b then Right a else Left b

try :: forall a eff. Eff (err :: EXCEPTION | eff) a -> Eff eff (Either Error a)
try action = catchException (pure <<< Left) (map Right action)

eqPath :: Path -> Path -> Boolean
eqPath (Path p1) (Path p2) = eq p1 p2

getPath :: Request -> Path
getPath = _.httpPath <<< runHttpRequest <<< getHttpReq

getHttpReq :: Request -> HttpRequest
getHttpReq req' = case req' of
  Subscribe hreq   -> hreq
  Unsubscribe hreq -> hreq
  SetPongRequest hreq -> hreq
  SetCloseRequest hreq -> hreq

runHttpRequest (HttpRequest req') = req'

 -- Copied from Data.StrMap (not exported):
mutate :: forall a b. (forall h . SM.STStrMap h a -> Eff (st :: ST.ST h ) b) -> StrMap a -> StrMap a
mutate f m = ST.pureST (do
  s <- myThawST m
  f s
  ST.unsafeGet s)

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

myThawST :: forall a h. StrMap a -> Eff ( st :: ST.ST h) (STStrMap h a)
myThawST = unsafeCoerce thawST

module Servant.Subscriber.Internal where

import Prelude
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Var as Var
import Control.Monad.ST as ST
import DOM.HTML.Event.ErrorEvent as ErrorEvent
import DOM.Websocket.Event.CloseEvent as CloseEvent
import Data.List as List
import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Servant.Subscriber.Response as Resp
import WebSocket as WS
import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, catchException)
import Control.Monad.Eff.Ref (Ref, REF, modifyRef, readRef, writeRef)
import DOM.Event.Types (keyboardEventToEvent, Event)
import DOM.Websocket.Event.Types (CloseEvent, MessageEvent)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Printer (printJson)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_, sequence_, elem, intercalate, foldl)
import Data.Function.Uncurried (Fn4)
import Data.Generic (gShow, gEq, gCompare, class Generic)
import Data.Lens ((^.), view, prism, (.~), _Just, _2)
import Data.Lens.At (at)
import Data.Lens.Lens (lens)
import Data.Lens.Types (PrismP, LensP)
import Data.List (List, filter)
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (thawST, pureST, StrMap)
import Data.StrMap.ST (STStrMap)
import Data.Tuple (Tuple(Tuple), fst)
import Partial.Unsafe (unsafeCrashWith)
import Servant.PureScript.Util (reportError)
import Servant.Subscriber.Request (HttpRequest(HttpRequest), Request(Subscribe, Unsubscribe, SetPongRequest, SetCloseRequest))
import Servant.Subscriber.Response (HttpResponse)
import Servant.Subscriber.Types (Path(Path))
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET, Message(Message), ReadyState(Open), newWebSocket)
import Data.StrMap.ST.Unsafe as ST

type SubscriberEff eff = Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff)

type Orders a = StrMap (Order a)

type Connection eff a = {
    orders       :: Ref (Orders a)
  , url          :: WS.URL
  , callback     ::  a -> SubscriberEff eff Unit
  , notify       ::  Notification -> SubscriberEff eff Unit
  , connection   :: Ref (Maybe WS.Connection)
  , pongRequest  :: Ref (Maybe HttpRequest)
  , closeRequest :: Ref (Maybe HttpRequest)
  }

type OrderKey = String

makeOrderKey :: HttpRequest -> OrderKey
makeOrderKey = gShow

-- | Information about a subscription:
--   What to subscribe and whom to respond to.
type Subscription a = {
    req :: HttpRequest
  , parseResponses :: List (ToUserType a)
  }

data Notification = WebSocketError String
           | WebSocketClosed String
           | HttpRequestFailed HttpRequest HttpResponse
           | ParseError String -- |< Server response could not be parsed/ Server could not parse our request.

derive instance genericNotification :: Generic Notification

-- | Convert a json modified response to a user specified sum type.
--   The given parameter is 'Nothing' on a Deleted event.
type ToUserType a = Maybe Json -> Either String a

data SubscriptionState = Ordered | Sent | Confirmed

derive instance eqSubscriptionState :: Eq SubscriptionState

type Order a = {
    req :: Request
  , parseResponses :: List (ToUserType a)
  , state :: SubscriptionState
  }

req :: forall r a. LensP ({ req :: a | r}) a
req = lens _.req (\r -> r { req = _ })

state :: forall r a. LensP ({ state :: a | r}) a
state = lens _.state (\r -> r { state = _ })

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

-- | Call this function to actually send requests to the server.
realize :: forall eff a. Connection eff a -> SubscriberEff eff Unit
realize impl = do
      mc <- readRef impl.connection
      case mc of
          Nothing -> makeConnection impl
          Just c'@(WS.Connection c) -> do
            rdy <- Var.get c.readyState
            case rdy of
              Open -> sendRequests c' impl
              _    -> pure unit

-- | Takes care of actually subscribing stuff.
sendRequests :: forall eff a. WS.Connection -> Connection eff a -> SubscriberEff eff Unit
sendRequests (WS.Connection conn) impl = do
      ordered <- List.filter ((_ == Ordered) <<< _.state) <<< StrMap.values <$> Ref.readRef impl.orders
      let
        mkMsg :: Request -> Message
        mkMsg = Message <<< printJson <<< encodeJson

        msgs = map (mkMsg <<< _.req) ordered

      sequence_ $ map conn.send msgs
    --  modifyRef impl.subscriptions $ over (mapped <<< state <<< match Requested) (const Sent) -- Does not work currently.
    --  modifyRef impl.subscriptions $ traverse <<< state <<< filtered (_ == Ordered) .~ Sent -- Does not work currently
      modifyRef impl.orders $ map (\sub -> if sub.state == Ordered then sub { state = Sent } else sub)

initConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
initConnection impl = do
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> makeConnection impl
        Just _ -> pure unit

makeConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
makeConnection impl = do
      WS.Connection conn <- newWebSocket impl.url []
      Var.set conn.onclose   $ closeHandler impl
      Var.set conn.onmessage $ messageHandler impl
      Var.set conn.onerror   $ errorHandler impl
      Var.set conn.onopen    $ openHandler (WS.Connection conn) impl
      writeRef impl.connection $ Just (WS.Connection conn)

openHandler :: forall eff a. WS.Connection -> Connection eff a -> Event -> SubscriberEff eff Unit
openHandler conn impl _ = sendRequests conn impl

closeHandler :: forall eff a. Connection eff a -> CloseEvent -> SubscriberEff eff Unit
closeHandler impl ev = do
      writeRef impl.connection Nothing
      subs <- readRef impl.orders
      if StrMap.isEmpty subs
        then pure unit
        else do
          modifyRef impl.orders $ updateSubscriptions
          makeConnection impl
      impl.notify $ WebSocketClosed ("code: " <> (show <<< CloseEvent.code) ev <> ", reason: " <> CloseEvent.reason ev)
  where
    isUnsubscribe :: Request -> Boolean
    isUnsubscribe (Unsubscribe _) = true
    isUnsubscribe _ = false

    updateSubscriptions :: Orders a -> Orders a
    updateSubscriptions subs = let
          forRemoval = map fst <<< List.filter (isUnsubscribe <<< view (_2 <<< req)) <<< StrMap.toList $ subs
          cleanedSubs = foldl (flip StrMap.delete) subs forRemoval
        in
          map ( _ { state = Ordered } ) cleanedSubs

errorHandler :: forall eff a. Connection eff a -> Event -> SubscriberEff eff Unit
errorHandler impl ev = do
      impl.notify $ WebSocketError ((ErrorEvent.message <<< unsafeCoerce) ev)
      realize impl -- Something went wrong - retry. (TODO: Probably better with some timeout!)

messageHandler :: forall eff a. Connection eff a -> MessageEvent -> SubscriberEff eff Unit
messageHandler impl msgEvent =  do
      let msg = WS.runMessage <<< WS.runMessageEvent $ msgEvent
      let eDecoded = decodeJson <=< jsonParser $ msg
      case eDecoded of
        Left err -> impl.notify $ ParseError (err <> ", input: '" <> msg <> "'")
        Right resp -> do
            modifyRef impl.orders $ case resp of
                Resp.Subscribed req'          -> onlyIfSent req' $ \key -> at key <<< _Just <<< state .~ Confirmed
                Resp.Deleted path             -> handleDelete path
                Resp.Unsubscribed req'        -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.Modified _ _             -> id
                Resp.HttpRequestFailed req' _ -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.ParseError               -> id
            orders' <- readRef impl.orders
            case resp of
              Resp.Modified req' val            -> doCallback req' (Just val) impl
              Resp.Deleted  path                -> traverse_ (\order' -> doCallback (getHttpReq order'.req) Nothing impl)
                                                   $ getOrdersByPath path orders'
              Resp.HttpRequestFailed req' resp' -> impl.notify $ HttpRequestFailed req' resp'
              Resp.ParseError                   -> impl.notify $ ParseError "Server could not parse our request!"
              Resp.Subscribed _                 -> pure unit
              Resp.Unsubscribed _               -> pure unit

-- | Only update our orders from messageHandler if state is still `Sent` to avoid overriding of more recent user requests.
onlyIfSent :: forall a. HttpRequest -> (OrderKey -> Orders a -> Orders a) -> Orders a -> Orders a
onlyIfSent req' action orders' =
  let
    key = makeOrderKey req'
    order' = orders' ^. at key
  in
   case (_.state) <$> order' of
     Just Sent -> action key orders'
     _    -> orders'

handleDelete :: forall a. Path -> Orders a -> Orders a
handleDelete p = StrMap.fromList <<< filter canStay <<< StrMap.toList
  where
    canStay :: Tuple String (Order a) -> Boolean
    canStay (Tuple _ order) = let req' = runHttpRequest $ getHttpReq order.req
                              in
                               (not <<< eqPath) req'.httpPath p || order.state /= Confirmed -- Only delete if already successfully subscribed!

getOrdersByPath :: forall a. Path -> Orders a -> List (Order a)
getOrdersByPath path = filter (eqPath path <<< getPath <<< _.req) <<< StrMap.values

doCallback :: forall eff a. HttpRequest -> Maybe String -> Connection eff a -> SubscriberEff eff Unit
doCallback req' res impl = do
  orders' <- readRef impl.orders
  let
    order' = case StrMap.lookup (makeOrderKey req') orders' of
      Nothing -> unsafeCrashWith $ "Received a message for an unregistered handler: " <> gShow req'
      Just o -> o
    parsers = order'.parseResponses
    eitherVals :: List (Either String a)
    eitherVals = case res of
      Nothing ->  map (_ $ Nothing) parsers
      Just str -> flip doDecode str <$> parsers
    handleEitherVal :: Either String a -> SubscriberEff eff Unit
    handleEitherVal eitherVal =case eitherVal of
      Right decoded -> impl.callback decoded
      Left err -> impl.notify $ ParseError err
  traverse_ handleEitherVal eitherVals

doDecode :: forall a. ToUserType a -> String -> Either String a
doDecode parser str = do
      jVal <- lmap (reportError id str <<< ("Parsing json response failed: " <> _))
              <<< jsonParser $ str
      parser $ Just jVal

-- | Prism for only setting a value if it is equal to a.
match :: forall a. Eq a => a -> PrismP a a
match a = prism id $ \b -> if a == b then Right a else Left b

try :: forall a eff. Eff (err :: EXCEPTION | eff) a -> Eff eff (Either Error a)
try action = catchException (pure <<< Left) (map Right action)

eqPath :: Path -> Path -> Boolean
eqPath (Path p1) (Path p2) = eq p1 p2

getPath :: Request -> Path
getPath = _.httpPath <<< runHttpRequest <<< getHttpReq

getHttpReq :: Request -> HttpRequest
getHttpReq req' = case req' of
  Subscribe hreq   -> hreq
  Unsubscribe hreq -> hreq
  SetPongRequest hreq -> hreq
  SetCloseRequest hreq -> hreq

runHttpRequest (HttpRequest req') = req'

 -- Copied from Data.StrMap (not exported):
mutate :: forall a b. (forall h . SM.STStrMap h a -> Eff (st :: ST.ST h ) b) -> StrMap a -> StrMap a
mutate f m = ST.pureST (do
  s <- myThawST m
  f s
  ST.unsafeGet s)

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

myThawST :: forall a h. StrMap a -> Eff ( st :: ST.ST h) (STStrMap h a)
myThawST = unsafeCoerce thawST


remove unnecessary Image data from IR

remove unnecessary Image data from IR

module IR where

import Data.Maybe
import Data.StrMap

type Int = Number
type Word = Number
type Float = Number
type Int16 = Number
type Int32 = Number
type Word16 = Number
type Word32 = Number
type Bool = Boolean

data V2 a = V2 a a
data V3 a = V3 a a a
data V4 a = V4 a a a a

-- matrices are stored in column major order
type M22F = V2 V2F
type M23F = V3 V2F
type M24F = V4 V2F
type M32F = V2 V3F
type M33F = V3 V3F
type M34F = V4 V3F
type M42F = V2 V4F
type M43F = V3 V4F
type M44F = V4 V4F

type V2F = V2 Float
type V3F = V3 Float
type V4F = V4 Float
type V2I = V2 Int32
type V3I = V3 Int32
type V4I = V4 Int32
type V2U = V2 Word32
type V3U = V3 Word32
type V4U = V4 Word32
type V2B = V2 Bool
type V3B = V3 Bool
type V4B = V4 Bool

-- GPU type value reification, needed for shader codegen
data Value
    = VBool     Bool
    | VV2B      V2B
    | VV3B      V3B
    | VV4B      V4B
    | VWord     Word32
    | VV2U      V2U
    | VV3U      V3U
    | VV4U      V4U
    | VInt      Int32
    | VV2I      V2I
    | VV3I      V3I
    | VV4I      V4I
    | VFloat    Float
    | VV2F      V2F
    | VV3F      V3F
    | VV4F      V4F
    | VM22F     M22F
    | VM23F     M23F
    | VM24F     M24F
    | VM32F     M32F
    | VM33F     M33F
    | VM34F     M34F
    | VM42F     M42F
    | VM43F     M43F
    | VM44F     M44F

data InputType
    = Bool
    | V2B
    | V3B
    | V4B
    | Word
    | V2U
    | V3U
    | V4U
    | Int
    | V2I
    | V3I
    | V4I
    | Float
    | V2F
    | V3F
    | V4F
    | M22F
    | M23F
    | M24F
    | M32F
    | M33F
    | M34F
    | M42F
    | M43F
    | M44F
    -- shadow textures
    | STexture1D
    | STexture2D
    | STextureCube
    | STexture1DArray
    | STexture2DArray
    | STexture2DRect
    -- float textures
    | FTexture1D
    | FTexture2D
    | FTexture3D
    | FTextureCube
    | FTexture1DArray
    | FTexture2DArray
    | FTexture2DMS
    | FTexture2DMSArray
    | FTextureBuffer
    | FTexture2DRect
    -- int textures
    | ITexture1D
    | ITexture2D
    | ITexture3D
    | ITextureCube
    | ITexture1DArray
    | ITexture2DArray
    | ITexture2DMS
    | ITexture2DMSArray
    | ITextureBuffer
    | ITexture2DRect
    -- uint textures
    | UTexture1D
    | UTexture2D
    | UTexture3D
    | UTextureCube
    | UTexture1DArray
    | UTexture2DArray
    | UTexture2DMS
    | UTexture2DMSArray
    | UTextureBuffer
    | UTexture2DRect

data PointSpriteCoordOrigin = LowerLeft | UpperLeft
data PointSize              = PointSize Float | ProgramPointSize
data PolygonOffset          = NoOffset | Offset Float Float
data FrontFace              = CCW | CW
data PolygonMode            = PolygonPoint PointSize | PolygonLine Float | PolygonFill
data ProvokingVertex        = FirstVertex | LastVertex
data CullMode               = CullNone | CullFront FrontFace | CullBack FrontFace
type DepthFunction          = ComparisonFunction
data ComparisonFunction     = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always
data StencilOperation       = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert
data BlendEquation          = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max
data BlendingFactor         = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate
data LogicOperation         = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set

data StencilOps = StencilOps
    { frontStencilOp    :: StencilOperation -- ^ Used for front faced triangles and other primitives.
    , backStencilOp     :: StencilOperation -- ^ Used for back faced triangles.
    }

data StencilTests = StencilTests StencilTest StencilTest
data StencilTest = StencilTest
    { stencilComparision    :: ComparisonFunction   -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
    , stencilReference      :: Int32                -- ^ The value to compare with the stencil buffer's value.
    , stencilMask           :: Word32               -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
    }

-- primitive types
data FetchPrimitive
    = Points
    | Lines
    | Triangles
    | LinesAdjacency
    | TrianglesAdjacency

instance eqFetchPrimitive :: Eq (FetchPrimitive) where
  (==) Points             Points              = true
  (==) Lines              Lines               = true
  (==) Triangles          Triangles           = true
  (==) LinesAdjacency     LinesAdjacency      = true
  (==) TrianglesAdjacency TrianglesAdjacency  = true
  (/=) a                  b                   = not (a == b)

instance showFetchPrimitive :: Show (FetchPrimitive) where
  show Points             = "Points"
  show Lines              = "Lines"
  show Triangles          = "Triangles"
  show LinesAdjacency     = "LinesAdjacency"
  show TrianglesAdjacency = "TrianglesAdjacency"

data OutputPrimitive
    = TrianglesOutput
    | LinesOutput
    | PointsOutput

data ColorArity = Red | RG | RGB | RGBA

data BlendingFactorPair = BlendingFactorPair {src :: BlendingFactor, dst :: BlendingFactor}
data Blending
    = NoBlending
    | BlendLogicOp  LogicOperation
    | Blend         {colorEq :: BlendEquation, alphaEq :: BlendEquation}
                    {colorF :: BlendingFactorPair, alphaF :: BlendingFactorPair}
                    V4F

data RasterContext
    = PointCtx      PointSize Float PointSpriteCoordOrigin
    | LineCtx       Float ProvokingVertex
    | TriangleCtx   CullMode PolygonMode PolygonOffset ProvokingVertex

data FragmentOperation
    = DepthOp       DepthFunction Bool
    | StencilOp     StencilTests StencilOps StencilOps
    | ColorOp       Blending Value

data AccumulationContext = AccumulationContext
    { accViewportName   :: Maybe String
    , accOperations     :: [FragmentOperation]
    }

data TextureDataType
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT

data TextureType
    = Texture1D     TextureDataType Int
    | Texture2D     TextureDataType Int
    | Texture3D     TextureDataType
    | TextureCube   TextureDataType
    | TextureRect   TextureDataType
    | Texture2DMS   TextureDataType Int Int Bool
    | TextureBuffer TextureDataType

data MipMap
    = Mip           Int Int -- Base level, Max level
    | NoMip
    | AutoMip       Int Int -- Base level, Max level

data Filter
    = Nearest
    | Linear
    | NearestMipmapNearest
    | NearestMipmapLinear
    | LinearMipmapNearest
    | LinearMipmapLinear

data EdgeMode
    = Repeat
    | MirroredRepeat
    | ClampToEdge
    | ClampToBorder

type ProgramName = Int
type TextureName = Int
type SamplerName = Int
type UniformName = String
type SlotName = Int
type FrameBufferComponent = Int
type TextureUnit = Int
type RenderTargetName = Int
type TextureUnitMapping = StrMap TextureUnit

data ImageRef
    = TextureImage  TextureName Int (Maybe Int)  -- Texture name, mip index, array index
    | Framebuffer   ImageSemantic

data ImageSemantic
    = Depth
    | Stencil
    | Color

data ClearImage = ClearImage {semantic :: ImageSemantic, value :: Value}
data Command
    = SetRasterContext          RasterContext
    | SetAccumulationContext    AccumulationContext
    | SetRenderTarget           RenderTargetName
    | SetProgram                ProgramName --TextureUnitMapping    -- adding texture unit map to set program command seems to be better solution than the current one
    | SetSamplerUniform         UniformName TextureUnit             -- hint: currently the texture unit mapping is encoded with this command
    | SetTexture                TextureUnit TextureName             -- binds texture to the specified texture unit
    | SetSampler                TextureUnit (Maybe SamplerName)     -- binds sampler to the specified texture unit
    | RenderSlot                SlotName
    | ClearRenderTarget         [ClearImage]
    | GenerateMipMap            TextureUnit
    | SaveImage                 FrameBufferComponent ImageRef                            -- from framebuffer component to texture (image)
    | LoadImage                 ImageRef FrameBufferComponent                            -- from texture (image) to framebuffer component

data TextureDescriptor = TextureDescriptor  -- texture size, type, array, mipmap
    { textureType       :: TextureType
    , textureSize       :: Value
    , textureSemantic   :: ImageSemantic
    , textureSampler    :: SamplerDescriptor
    , textureBaseLevel  :: Int
    , textureMaxLevel   :: Int
    }

data SamplerDescriptor = SamplerDescriptor
    { samplerWrapS          :: EdgeMode
    , samplerWrapT          :: Maybe EdgeMode
    , samplerWrapR          :: Maybe EdgeMode
    , samplerMinFilter      :: Filter
    , samplerMagFilter      :: Filter
    , samplerBorderColor    :: Value
    , samplerMinLod         :: Maybe Float
    , samplerMaxLod         :: Maybe Float
    , samplerLodBias        :: Float
    , samplerCompareFunc    :: Maybe ComparisonFunction
    }

data Parameter = Parameter {name::String,ty::InputType}
data Program = Program  -- AST, input
    { programUniforms   :: StrMap InputType    -- uniform input (value based uniforms only / no textures)
    , programStreams    :: StrMap Parameter  -- vertex shader input attribute name -> (slot attribute name, attribute type)
    , programInTextures :: StrMap InputType               -- all textures (uniform textures and render textures) referenced by the program
    , programOutput     :: [Parameter]
    , vertexShader      :: String
    , geometryShader    :: Maybe String
    , fragmentShader    :: String
    }

data Slot = Slot      -- input, primitive type
    { slotName      :: String
    , slotUniforms  :: StrMap InputType
    , slotStreams   :: StrMap InputType
    , slotPrimitive :: FetchPrimitive
    , slotPrograms  :: [ProgramName]
    }

data TargetItem = TargetItem {semantic::ImageSemantic,ref::Maybe ImageRef}
data RenderTarget = RenderTarget
    { renderTargets :: [TargetItem] -- render texture or default framebuffer (semantic, render texture for the program output)
    }

data Pipeline = Pipeline
    { textures      :: [TextureDescriptor]
    , samplers      :: [SamplerDescriptor]
    , targets       :: [RenderTarget]
    , programs      :: [Program]
    , slots         :: [Slot]
    , commands      :: [Command]
    }

module IR where

import Data.Maybe
import Data.StrMap

type Int = Number
type Word = Number
type Float = Number
type Int16 = Number
type Int32 = Number
type Word16 = Number
type Word32 = Number
type Bool = Boolean

data V2 a = V2 a a
data V3 a = V3 a a a
data V4 a = V4 a a a a

-- matrices are stored in column major order
type M22F = V2 V2F
type M23F = V3 V2F
type M24F = V4 V2F
type M32F = V2 V3F
type M33F = V3 V3F
type M34F = V4 V3F
type M42F = V2 V4F
type M43F = V3 V4F
type M44F = V4 V4F

type V2F = V2 Float
type V3F = V3 Float
type V4F = V4 Float
type V2I = V2 Int32
type V3I = V3 Int32
type V4I = V4 Int32
type V2U = V2 Word32
type V3U = V3 Word32
type V4U = V4 Word32
type V2B = V2 Bool
type V3B = V3 Bool
type V4B = V4 Bool

-- GPU type value reification, needed for shader codegen
data Value
    = VBool     Bool
    | VV2B      V2B
    | VV3B      V3B
    | VV4B      V4B
    | VWord     Word32
    | VV2U      V2U
    | VV3U      V3U
    | VV4U      V4U
    | VInt      Int32
    | VV2I      V2I
    | VV3I      V3I
    | VV4I      V4I
    | VFloat    Float
    | VV2F      V2F
    | VV3F      V3F
    | VV4F      V4F
    | VM22F     M22F
    | VM23F     M23F
    | VM24F     M24F
    | VM32F     M32F
    | VM33F     M33F
    | VM34F     M34F
    | VM42F     M42F
    | VM43F     M43F
    | VM44F     M44F

data InputType
    = Bool
    | V2B
    | V3B
    | V4B
    | Word
    | V2U
    | V3U
    | V4U
    | Int
    | V2I
    | V3I
    | V4I
    | Float
    | V2F
    | V3F
    | V4F
    | M22F
    | M23F
    | M24F
    | M32F
    | M33F
    | M34F
    | M42F
    | M43F
    | M44F
    -- shadow textures
    | STexture1D
    | STexture2D
    | STextureCube
    | STexture1DArray
    | STexture2DArray
    | STexture2DRect
    -- float textures
    | FTexture1D
    | FTexture2D
    | FTexture3D
    | FTextureCube
    | FTexture1DArray
    | FTexture2DArray
    | FTexture2DMS
    | FTexture2DMSArray
    | FTextureBuffer
    | FTexture2DRect
    -- int textures
    | ITexture1D
    | ITexture2D
    | ITexture3D
    | ITextureCube
    | ITexture1DArray
    | ITexture2DArray
    | ITexture2DMS
    | ITexture2DMSArray
    | ITextureBuffer
    | ITexture2DRect
    -- uint textures
    | UTexture1D
    | UTexture2D
    | UTexture3D
    | UTextureCube
    | UTexture1DArray
    | UTexture2DArray
    | UTexture2DMS
    | UTexture2DMSArray
    | UTextureBuffer
    | UTexture2DRect

data PointSpriteCoordOrigin = LowerLeft | UpperLeft
data PointSize              = PointSize Float | ProgramPointSize
data PolygonOffset          = NoOffset | Offset Float Float
data FrontFace              = CCW | CW
data PolygonMode            = PolygonPoint PointSize | PolygonLine Float | PolygonFill
data ProvokingVertex        = FirstVertex | LastVertex
data CullMode               = CullNone | CullFront FrontFace | CullBack FrontFace
type DepthFunction          = ComparisonFunction
data ComparisonFunction     = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always
data StencilOperation       = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert
data BlendEquation          = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max
data BlendingFactor         = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate
data LogicOperation         = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set

data StencilOps = StencilOps
    { frontStencilOp    :: StencilOperation -- ^ Used for front faced triangles and other primitives.
    , backStencilOp     :: StencilOperation -- ^ Used for back faced triangles.
    }

data StencilTests = StencilTests StencilTest StencilTest
data StencilTest = StencilTest
    { stencilComparision    :: ComparisonFunction   -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
    , stencilReference      :: Int32                -- ^ The value to compare with the stencil buffer's value.
    , stencilMask           :: Word32               -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
    }

-- primitive types
data FetchPrimitive
    = Points
    | Lines
    | Triangles
    | LinesAdjacency
    | TrianglesAdjacency

instance eqFetchPrimitive :: Eq (FetchPrimitive) where
  (==) Points             Points              = true
  (==) Lines              Lines               = true
  (==) Triangles          Triangles           = true
  (==) LinesAdjacency     LinesAdjacency      = true
  (==) TrianglesAdjacency TrianglesAdjacency  = true
  (/=) a                  b                   = not (a == b)

instance showFetchPrimitive :: Show (FetchPrimitive) where
  show Points             = "Points"
  show Lines              = "Lines"
  show Triangles          = "Triangles"
  show LinesAdjacency     = "LinesAdjacency"
  show TrianglesAdjacency = "TrianglesAdjacency"

data OutputPrimitive
    = TrianglesOutput
    | LinesOutput
    | PointsOutput

data ColorArity = Red | RG | RGB | RGBA

data BlendingFactorPair = BlendingFactorPair {src :: BlendingFactor, dst :: BlendingFactor}
data Blending
    = NoBlending
    | BlendLogicOp  LogicOperation
    | Blend         {colorEq :: BlendEquation, alphaEq :: BlendEquation}
                    {colorF :: BlendingFactorPair, alphaF :: BlendingFactorPair}
                    V4F

data RasterContext
    = PointCtx      PointSize Float PointSpriteCoordOrigin
    | LineCtx       Float ProvokingVertex
    | TriangleCtx   CullMode PolygonMode PolygonOffset ProvokingVertex

data FragmentOperation
    = DepthOp       DepthFunction Bool
    | StencilOp     StencilTests StencilOps StencilOps
    | ColorOp       Blending Value

data AccumulationContext = AccumulationContext
    { accViewportName   :: Maybe String
    , accOperations     :: [FragmentOperation]
    }

data Image
    = DepthImage    Int Float
    | StencilImage  Int Int32
    | ColorImage    Int Value

data TextureDataType
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT

data TextureType
    = Texture1D     TextureDataType Int
    | Texture2D     TextureDataType Int
    | Texture3D     TextureDataType
    | TextureCube   TextureDataType
    | TextureRect   TextureDataType
    | Texture2DMS   TextureDataType Int Int Bool
    | TextureBuffer TextureDataType

data MipMap
    = Mip           Int Int -- Base level, Max level
    | NoMip
    | AutoMip       Int Int -- Base level, Max level

data Filter
    = Nearest
    | Linear
    | NearestMipmapNearest
    | NearestMipmapLinear
    | LinearMipmapNearest
    | LinearMipmapLinear

data EdgeMode
    = Repeat
    | MirroredRepeat
    | ClampToEdge
    | ClampToBorder

type ProgramName = Int
type TextureName = Int
type SamplerName = Int
type UniformName = String
type SlotName = Int
type FrameBufferComponent = Int
type TextureUnit = Int
type RenderTargetName = Int
type TextureUnitMapping = StrMap TextureUnit

data ImageRef
    = TextureImage  TextureName Int (Maybe Int)  -- Texture name, mip index, array index
    | Framebuffer   ImageSemantic

data ImageSemantic
    = Depth
    | Stencil
    | Color

data ClearImage = ClearImage {semantic :: ImageSemantic, value :: Value}
data Command
    = SetRasterContext          RasterContext
    | SetAccumulationContext    AccumulationContext
    | SetRenderTarget           RenderTargetName
    | SetProgram                ProgramName --TextureUnitMapping    -- adding texture unit map to set program command seems to be better solution than the current one
    | SetSamplerUniform         UniformName TextureUnit             -- hint: currently the texture unit mapping is encoded with this command
    | SetTexture                TextureUnit TextureName             -- binds texture to the specified texture unit
    | SetSampler                TextureUnit (Maybe SamplerName)     -- binds sampler to the specified texture unit
    | RenderSlot                SlotName
    | ClearRenderTarget         [ClearImage]
    | GenerateMipMap            TextureUnit
    | SaveImage                 FrameBufferComponent ImageRef                            -- from framebuffer component to texture (image)
    | LoadImage                 ImageRef FrameBufferComponent                            -- from texture (image) to framebuffer component

data TextureDescriptor = TextureDescriptor  -- texture size, type, array, mipmap
    { textureType       :: TextureType
    , textureSize       :: Value
    , textureSemantic   :: ImageSemantic
    , textureSampler    :: SamplerDescriptor
    , textureBaseLevel  :: Int
    , textureMaxLevel   :: Int
    }

data SamplerDescriptor = SamplerDescriptor
    { samplerWrapS          :: EdgeMode
    , samplerWrapT          :: Maybe EdgeMode
    , samplerWrapR          :: Maybe EdgeMode
    , samplerMinFilter      :: Filter
    , samplerMagFilter      :: Filter
    , samplerBorderColor    :: Value
    , samplerMinLod         :: Maybe Float
    , samplerMaxLod         :: Maybe Float
    , samplerLodBias        :: Float
    , samplerCompareFunc    :: Maybe ComparisonFunction
    }

data Parameter = Parameter {name::String,ty::InputType}
data Program = Program  -- AST, input
    { programUniforms   :: StrMap InputType    -- uniform input (value based uniforms only / no textures)
    , programStreams    :: StrMap Parameter  -- vertex shader input attribute name -> (slot attribute name, attribute type)
    , programInTextures :: StrMap InputType               -- all textures (uniform textures and render textures) referenced by the program
    , programOutput     :: [Parameter]
    , vertexShader      :: String
    , geometryShader    :: Maybe String
    , fragmentShader    :: String
    }

data Slot = Slot      -- input, primitive type
    { slotName      :: String
    , slotUniforms  :: StrMap InputType
    , slotStreams   :: StrMap InputType
    , slotPrimitive :: FetchPrimitive
    , slotPrograms  :: [ProgramName]
    }

data TargetItem = TargetItem {semantic::ImageSemantic,ref::Maybe ImageRef}
data RenderTarget = RenderTarget
    { renderTargets :: [TargetItem] -- render texture or default framebuffer (semantic, render texture for the program output)
    }

data Pipeline = Pipeline
    { textures      :: [TextureDescriptor]
    , samplers      :: [SamplerDescriptor]
    , targets       :: [RenderTarget]
    , programs      :: [Program]
    , slots         :: [Slot]
    , commands      :: [Command]
    }


[CSE-212] Downcase EN times

[CSE-212] Downcase EN times

(cherry picked from commit 6a4a026c25fdc51761233ea5dae782f4c75f2305)

module Explorer.I18n.EN where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "Back"
        , cApi: "Api"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "Transaction"
        , cTransactions: "Transactions"
        , cTransactionFeed: "Transactions Feed"
        , cAddress: "Address"
        , cAddresses: "Addresses"
        , cVersion: "version"
        , cCalculator: "Calculator"
        , cNetwork: "Network"
        , cSummary: "Summary"
        , cBlock: "Slot"
        , cGenesis: "Genesis block"
        , cHash: "Hash"
        , cHashes: "Hashes"
        , cEpoch: "Epoch"
        , cEpochs: "Epochs"
        , cSlot: "Slot"
        , cSlots: "Slots"
        , cAge: "Since"
        , cTotalSent: "Total Sent"
        , cBlockLead: "Slot leader"
        , cSize: "Size (bytes)"
        , cExpand: "Expand"
        , cCollapse: "Collapse"
        , cNoData: "No data"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "Unknown"
        , cTotalOutput: "Total Output"
        , cOf: "of"
        , cNotAvailable: "not available"
        , cLoading: "Loading..."
        , cBack2Dashboard: "Back to Dashboard"
        , cYes: "yes"
        , cNo: "no"
        , cDays: "days"
        , cHours: "hours"
        , cMinutes: "minutes"
        , cSeconds: "seconds"
        , cDateFormat: "MM/DD/YYYY HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "Home"
        , navBlockchain: "Blockchain"
        , navMarket: "Market"
        , navCharts: "Charts"
        , navTools: "Tools"
        }
    , hero:
        { hrSubtitle: "Search addresses, transactions, epochs & slots on the Cardano network"
        , hrSearch: "Search for addresses, transactions, slots and epochs"
        , hrTime: "Time"
        }
    , dashboard:
        { dbTitle: "Dashboard"
        , dbLastBlocks: "Last slots"
        , dbLastBlocksDescription: "On {0} {1} transactions are generated"
        , dbPriceAverage: "Price (average)"
        , dbPriceForOne: "{0} for 1 {1}"
        , dbPriceSince: "{0} since yesterday."
        , dbTotalSupply: "Total supply"
        , dbTotalAmountOf: "Amount of {0} in the system."
        , dbTotalAmountOfTransactions: "Total amount of transactions detected in system since the beginning."
        , dbExploreBlocks: "Explore slots"
        , dbExploreTransactions: "Explore transactions"
        , dbBlockchainOffer: "What do we offer on our block explorer"
        , dbBlockSearch: "Slot search"
        , dbBlockSearchDescription: "Slot is a box where transactions are stored."
        , dbAddressSearch: "Address search"
        , dbAddressSearchDescription: "Address search"
        , dbTransactionSearch: "Transaction search"
        , dbTransactionSearchDescription: "Transaction is a transfer of coins from user 'A' to user 'B'."
        , dbApiDescription: "Our robust API is available in a variety of languages & SDKs."
        , dbGetAddress: "Get Address"
        , dbResponse: "Response"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "Get API key"
        , dbMoreExamples: "See more examples"
        , dbAboutBlockchain: "About Blockchain"
        , dbAboutBlockchainDescription: "Blockchain API makes it easy yo build cryptocurrencies applications and features. We are focused on providing a platform that enables developers to create fast, scalable, secure services.

This API is free and unlimited while we are in beta. We are just getting started, and will be rolling out more endpoints and features in the coming weeks. We want to build the API you need, so please send us requests, suggestions, or just say hello."
        }
    , address:
        { addScan: "Scan this QR Code to copy address to clipboard"
        , addQrCode: "QR-Code"
        , addFinalBalance: "Final balance"
        , addNotFound: "Address does not exist."
        }
    , tx:
        { txTime: "Received time"
        , txIncluded: "Included in"
        , txRelayed: "Relayed by IP"
        , txEmpty: "No transactions"
        , txFees: "Transaction fee"
        , txNotFound: "Transaction does not exist."
        }
    , block:
        { blFees: "Fees"
        , blEstVolume: "Est. Volume"
        , blPrevBlock: "Previous slot"
        , blNextBlock: "Next slot"
        , blRoot: "Merkle root"
        , blEpochSlotNotFound: "Epoch / slot do not exist."
        , blSlotNotFound: "Slot does not exist."
        }
    , genesisBlock:
        { gblNotFound: "Genesis block not found."
        , gblNumberRedeemedAddresses: "Redeemed addresses"
        , gblAddressesNotFound: "Addresses do not exists."
        , gblAddressesError: "Error while trying to load addresses."
        , gblAddressRedeemAmount: "Redeemed amount"
        , gblAddressIsRedeemed: "Redeemed"
        }
    , footer:
        { fooResources: "Resources"
        , fooFollow: "Follow us"
        , fooLinks: "Links"
        , fooIohkSupportP: "IOHK supported project"
        , fooDocumentation: "Documentation"
        , fooGithub: "Github"
        , fooLinkedin: "Linkedin"
        , fooTwitter: "Twitter"
        , fooDaedalusWallet: "Daedalus Wallet"
        , fooWhyCardano: "Why Cardano"
        , fooCardanoRoadmap: "Cardano Roadmap"
        , fooCardanoADAFaucet: "Cardano ADA Faucet"
        , fooCardanoSLDocumentation: "Cardano SL Documentation"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "Page not found"
        }
    }

module Explorer.I18n.EN where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "Back"
        , cApi: "Api"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "Transaction"
        , cTransactions: "Transactions"
        , cTransactionFeed: "Transactions Feed"
        , cAddress: "Address"
        , cAddresses: "Addresses"
        , cVersion: "version"
        , cCalculator: "Calculator"
        , cNetwork: "Network"
        , cSummary: "Summary"
        , cBlock: "Slot"
        , cGenesis: "Genesis block"
        , cHash: "Hash"
        , cHashes: "Hashes"
        , cEpoch: "Epoch"
        , cEpochs: "Epochs"
        , cSlot: "Slot"
        , cSlots: "Slots"
        , cAge: "Since"
        , cTotalSent: "Total Sent"
        , cBlockLead: "Slot leader"
        , cSize: "Size (bytes)"
        , cExpand: "Expand"
        , cCollapse: "Collapse"
        , cNoData: "No data"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "Unknown"
        , cTotalOutput: "Total Output"
        , cOf: "of"
        , cNotAvailable: "not available"
        , cLoading: "Loading..."
        , cBack2Dashboard: "Back to Dashboard"
        , cYes: "yes"
        , cNo: "no"
        , cDays: "Days"
        , cHours: "Hours"
        , cMinutes: "Minutes"
        , cSeconds: "Seconds"
        , cDateFormat: "MM/DD/YYYY HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "Home"
        , navBlockchain: "Blockchain"
        , navMarket: "Market"
        , navCharts: "Charts"
        , navTools: "Tools"
        }
    , hero:
        { hrSubtitle: "Search addresses, transactions, epochs & slots on the Cardano network"
        , hrSearch: "Search for addresses, transactions, slots and epochs"
        , hrTime: "Time"
        }
    , dashboard:
        { dbTitle: "Dashboard"
        , dbLastBlocks: "Last slots"
        , dbLastBlocksDescription: "On {0} {1} transactions are generated"
        , dbPriceAverage: "Price (average)"
        , dbPriceForOne: "{0} for 1 {1}"
        , dbPriceSince: "{0} since yesterday."
        , dbTotalSupply: "Total supply"
        , dbTotalAmountOf: "Amount of {0} in the system."
        , dbTotalAmountOfTransactions: "Total amount of transactions detected in system since the beginning."
        , dbExploreBlocks: "Explore slots"
        , dbExploreTransactions: "Explore transactions"
        , dbBlockchainOffer: "What do we offer on our block explorer"
        , dbBlockSearch: "Slot search"
        , dbBlockSearchDescription: "Slot is a box where transactions are stored."
        , dbAddressSearch: "Address search"
        , dbAddressSearchDescription: "Address search"
        , dbTransactionSearch: "Transaction search"
        , dbTransactionSearchDescription: "Transaction is a transfer of coins from user 'A' to user 'B'."
        , dbApiDescription: "Our robust API is available in a variety of languages & SDKs."
        , dbGetAddress: "Get Address"
        , dbResponse: "Response"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "Get API key"
        , dbMoreExamples: "See more examples"
        , dbAboutBlockchain: "About Blockchain"
        , dbAboutBlockchainDescription: "Blockchain API makes it easy yo build cryptocurrencies applications and features. We are focused on providing a platform that enables developers to create fast, scalable, secure services.

This API is free and unlimited while we are in beta. We are just getting started, and will be rolling out more endpoints and features in the coming weeks. We want to build the API you need, so please send us requests, suggestions, or just say hello."
        }
    , address:
        { addScan: "Scan this QR Code to copy address to clipboard"
        , addQrCode: "QR-Code"
        , addFinalBalance: "Final balance"
        , addNotFound: "Address does not exist."
        }
    , tx:
        { txTime: "Received time"
        , txIncluded: "Included in"
        , txRelayed: "Relayed by IP"
        , txEmpty: "No transactions"
        , txFees: "Transaction fee"
        , txNotFound: "Transaction does not exist."
        }
    , block:
        { blFees: "Fees"
        , blEstVolume: "Est. Volume"
        , blPrevBlock: "Previous slot"
        , blNextBlock: "Next slot"
        , blRoot: "Merkle root"
        , blEpochSlotNotFound: "Epoch / slot do not exist."
        , blSlotNotFound: "Slot does not exist."
        }
    , genesisBlock:
        { gblNotFound: "Genesis block not found."
        , gblNumberRedeemedAddresses: "Redeemed addresses"
        , gblAddressesNotFound: "Addresses do not exists."
        , gblAddressesError: "Error while trying to load addresses."
        , gblAddressRedeemAmount: "Redeemed amount"
        , gblAddressIsRedeemed: "Redeemed"
        }
    , footer:
        { fooResources: "Resources"
        , fooFollow: "Follow us"
        , fooLinks: "Links"
        , fooIohkSupportP: "IOHK supported project"
        , fooDocumentation: "Documentation"
        , fooGithub: "Github"
        , fooLinkedin: "Linkedin"
        , fooTwitter: "Twitter"
        , fooDaedalusWallet: "Daedalus Wallet"
        , fooWhyCardano: "Why Cardano"
        , fooCardanoRoadmap: "Cardano Roadmap"
        , fooCardanoADAFaucet: "Cardano ADA Faucet"
        , fooCardanoSLDocumentation: "Cardano SL Documentation"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "Page not found"
        }
    }


Final cleanups

Final cleanups

module App.AI where

import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import Data.Tuple as Tuple
import App.Board (Board, PitRef, Player, opponentOf)
import App.FixedMatrix72 (Ref(..), Row(..), getValues)
import Control.MonadZero (guard)
import Data.Array (filter, zipWith)
import Data.Foldable (maximum, maximumBy, sum)
import Data.Function (on)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), fst)
import Prelude (class Eq, class Monad, class Ord, class Show, bind, compare, const, eq, map, not, pure, show, ($), (&&), (+), (-), (/), (<$>), (<*>), (<<<), (<>), (==), (>))

type Move = Tuple PitRef Board

bestMove1 :: Board -> Player -> Maybe Move
bestMove1 board player =
  maximumBy bestOf $ possibleMoves board player
    where bestOf (Tuple _ b1) (Tuple _ b2) = on compare (effectiveScore player) b1 b2

-- Unlike bestMove1 consider opponent's best move as well.
bestMove2 :: Board -> Player -> Maybe Move
bestMove2 board player =
  fst <$> (maximumBy bestOf $ zipWith Tuple moves (calcScore <$> moves))
    where moves = possibleMoves board player
          calcScore m@(Tuple r b) = score b player (oppMove m)
          oppMove (Tuple r b) = bestMove1 b (opponentOf player)
          bestOf (Tuple _ s1) (Tuple _ s2) =
            compare s1 s2

possibleMoves :: Board -> Player -> Array Move
possibleMoves board player =
  zipWith Tuple possibleRefs nextBoards
    where nextBoards = simulateMove player board <$> possibleRefs
          possibleRefs = filter (canLift board) $ Board.refs player
          bestOf (Tuple _ b1) (Tuple _ b2) = on compare (effectiveScore player) b1 b2

score :: Board -> Player -> Maybe Move -> Int
score startBoard player Nothing =
  (sumInPit startBoard) + effectiveScore player startBoard
score startBoard player (Just (Tuple _ nextBoard)) =
  effectiveScore player nextBoard

-- Scoring algorithm. Pits in board is to be considered for balancing future moves.
effectiveScore :: Player -> Board -> Int
effectiveScore player board = playerStore + ((sumInPit board) / 2) -- opponentStore
  where playerStore = Board.getStore player board
        opponentStore = Board.getStore (Board.opponentOf player) board

sumInPit :: Board -> Int
sumInPit = sum <<< getValues <<< _.cells

canLift :: Board -> PitRef -> Boolean
canLift board r = Board.hasSeeds r board && not Board.isBlocked r board

simulateMove :: Player -> Board -> PitRef -> Board
simulateMove player board ref = Tuple.snd $ Turn.run state
    where state = Tuple hand board
          hand = Hand.init player ref

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< filter isJust

module App.AI where

import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import Data.Tuple as Tuple
import App.Board (Board, PitRef, Player, opponentOf)
import App.FixedMatrix72 (Ref(..), Row(..), getValues)
import Control.MonadZero (guard)
import Data.Array (filter, zipWith)
import Data.Foldable (maximum, maximumBy, sum)
import Data.Function (on)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Traversable (sequence, traverse)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Prelude (class Eq, class Monad, class Ord, class Show, bind, compare, const, eq, map, not, pure, show, ($), (&&), (+), (-), (/), (<$>), (<*>), (<<<), (<>), (==), (>))

-- TODO: Move to util.purs
getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< filter isJust

type Move = Tuple PitRef Board

bestMove :: Board -> Player -> Maybe Move
bestMove board player =
  maximumBy bestOf $ possibleMoves board player
    where bestOf (Tuple _ b1) (Tuple _ b2) = on compare (effectiveScore player) b1 b2

score :: Board -> Player -> Maybe Move -> Int
score startBoard player Nothing =
  (sumInPit startBoard) + effectiveScore player startBoard
score startBoard player (Just (Tuple _ nextBoard)) =
  effectiveScore player nextBoard

sumInPit :: Board -> Int
sumInPit = sum <<< getValues <<< _.cells

bestMove2 :: Board -> Player -> Maybe Move
bestMove2 board player =
  fst <$> (maximumBy bestOf $ zipWith Tuple moves (calcScore <$> moves))
    where moves = possibleMoves board player
          calcScore m@(Tuple r b) = score b player (oppMove m)
          oppMove (Tuple r b) = bestMove b (opponentOf player)
          bestOf (Tuple _ s1) (Tuple _ s2) =
            compare s1 s2

bestMove3 :: Board -> Player -> Maybe Move
bestMove3 board player =
  fst <$> (maximumBy bestOf $ zipWith Tuple moves (calcScore <$> moves))
    where moves = possibleMoves board player
          calcScore m@(Tuple r b) = score b player (oppMove m)
          oppMove (Tuple r b) = bestMove2 b (opponentOf player)
          bestOf (Tuple _ s1) (Tuple _ s2) =
            compare s1 s2

possibleMoves :: Board -> Player -> Array Move
possibleMoves board player =
  zipWith Tuple possibleRefs nextBoards
    where nextBoards = simulateMove player board <$> possibleRefs
          possibleRefs = filter (canLift board) $ Board.refs player
          bestOf (Tuple _ b1) (Tuple _ b2) = on compare (effectiveScore player) b1 b2

-- TODO: move to Board.purs
canLift :: Board -> PitRef -> Boolean
canLift board r = Board.hasSeeds r board && not Board.isBlocked r board

simulateMove :: Player -> Board -> PitRef -> Board
simulateMove player board ref = Tuple.snd $ Turn.run state
    where state = Tuple hand board
          hand = Hand.init player ref

effectiveScore :: Player -> Board -> Int
effectiveScore player board = playerStore + ((sumInPit board) / 2)-- opponentStore
  where playerStore = Board.getStore player board
        opponentStore = Board.getStore (Board.opponentOf player) board


more tests

more tests

module Test.LifeSpec where

import Prelude
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Life
import Life as Life
import Data.Maybe (Maybe(..))
import Data.List (List(..))
import Data.List as List
import Data.List.Zipper

spec :: forall r. Spec r Unit
spec = do
  let z = Zipper Nil 1 (List.fromFoldable [2, 3])
      z' = Zipper (List.fromFoldable [1]) 2 (List.fromFoldable [3])
      z'' = Zipper (List.fromFoldable [2, 1]) 3 Nil
  describe "upOrWrap" do
    it "moves a zipper up or wraps to end" $ do
      upOrWrap z `shouldEqual` z''
      upOrWrap z' `shouldEqual` z
      upOrWrap z'' `shouldEqual` z'
  describe "downOrWrap" do
    it "moves a zipper down or wraps to beginning" $ do
      downOrWrap z `shouldEqual` z'
      downOrWrap z' `shouldEqual` z''
      downOrWrap z'' `shouldEqual` z
  let z1 = Zipper Nil 1 (List.singleton 2)
      z2 = Zipper Nil 3 (List.singleton 4)
      z1' = Zipper (List.singleton 1) 2 Nil
      z2' = Zipper (List.singleton 3) 4 Nil
      planeZ = Z (Zipper Nil z1 (List.singleton z2))
      planeZ' = Z (Zipper (List.singleton z1) z2 Nil)
      planeZr = Z (Zipper Nil z1' (List.singleton z2'))
      planeZr' = Z (Zipper (List.singleton z1') z2' Nil)
      zArray = [[1,2], [3,4]]
  describe "fromFoldable" do
    it "converts a Foldable into a Z" do
      Life.fromFoldable zArray `shouldEqual` Just planeZ
  describe "toUnfoldable" do
    it "converts a Z into an Unfoldable" do
      Life.toUnfoldable planeZ `shouldEqual` zArray
  describe "zDown" do
    it "moves the cursor down one" do
      zDown planeZ `shouldEqual` Just planeZ'
      zDown planeZr `shouldEqual` Just planeZr'
  describe "zUp" do
    it "moves the cursor up one" do
      zUp planeZ' `shouldEqual` Just planeZ
      zUp planeZr' `shouldEqual` Just planeZr
  describe "zRight" do
    it "moves the cursor right one" do
      zRight planeZ `shouldEqual` Just planeZr
      zRight planeZ' `shouldEqual` Just planeZr'
  describe "zLeft" do
    it "moves the cursor left one" do
      zLeft planeZr `shouldEqual` Just planeZ
      zLeft planeZr' `shouldEqual` Just planeZ'

module Test.LifeSpec where

import Prelude
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Life
import Life as Life
import Data.Maybe (Maybe(..))
import Data.List (List(..))
import Data.List as List
import Data.List.Zipper

spec :: forall r. Spec r Unit
spec = do
  let z = Zipper Nil 1 (List.fromFoldable [2, 3])
      z' = Zipper (List.fromFoldable [1]) 2 (List.fromFoldable [3])
      z'' = Zipper (List.fromFoldable [2, 1]) 3 Nil
  describe "upOrWrap" do
    it "moves a zipper up or wraps to end" $ do
      upOrWrap z `shouldEqual` z''
      upOrWrap z' `shouldEqual` z
      upOrWrap z'' `shouldEqual` z'
  describe "downOrWrap" do
    it "moves a zipper down or wraps to beginning" $ do
      downOrWrap z `shouldEqual` z'
      downOrWrap z' `shouldEqual` z''
      downOrWrap z'' `shouldEqual` z
  let z1 = Zipper Nil 1 (List.singleton 2)
      z2 = Zipper Nil 3 (List.singleton 4)
      planeZ = Z (Zipper Nil z1 (List.singleton z2))
      zArray = [[1,2], [3,4]]
  describe "fromFoldable" do
    it "converts a Foldable into a Z" do
      Life.fromFoldable zArray `shouldEqual` Just planeZ
  describe "toUnfoldable" do
    it "converts a Z into an Unfoldable" do
      Life.toUnfoldable planeZ `shouldEqual` zArray


Remove ApproxNumber

Remove ApproxNumber

module Test.QuickCheck.Data.ApproxNumber
  ( ApproxNumber(..)
  , approximateEqual
  , (=~=)
  ) where

import Prelude

import Data.Newtype (class Newtype)

import Test.QuickCheck.Arbitrary (class Coarbitrary, class Arbitrary, coarbitrary, arbitrary)

-- | A newtype for `Number` whose `Eq` instance uses an epsilon value to allow
-- | for precision erros when comparing.
newtype ApproxNumber = ApproxNumber Number

derive instance newtypeApproxNumber :: Newtype ApproxNumber _

-- Approximate equality comparison
approximateEqual :: Number -> Number -> Boolean
approximateEqual x y = (y - x) <= epsilon && (y - x) >= (-epsilon)
  where
  epsilon = 0.00000001

infix 2 approximateEqual as =~=

instance arbitraryApproxNumber :: Arbitrary ApproxNumber where
  arbitrary = ApproxNumber <$> arbitrary

instance coarbitraryApproxNumber :: Coarbitrary ApproxNumber where
  coarbitrary (ApproxNumber n) = coarbitrary n

instance semiringApproxNumber :: Semiring ApproxNumber where
  add (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x + y)
  zero = ApproxNumber zero
  mul (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x * y)
  one = ApproxNumber one

instance ringApproxNumber :: Ring ApproxNumber where
  sub (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x - y)

instance commutativeRingApproxNumber :: CommutativeRing ApproxNumber

instance euclideanRingApproxNumber :: EuclideanRing ApproxNumber where
  degree (ApproxNumber x) = degree x
  div (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x / y)
  mod (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x `mod` y)

instance fieldApproxNumber :: Field ApproxNumber