<commit_before>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

{-
  Straight stolt on from virtual-dom
  virtual-dom bindings demo, rendering a large pixel grid with a bouncing red
  square. the step and patch are calculated asynchronously, the update is
  batched in an animation frame
 -}


module Main where

import           Data.Aeson
import           TankGauge
-- Base
import           Control.Applicative
import           Data.Maybe
import           Data.Traversable
-- import           Pipes.Concurrent
import           Prelude                        hiding (div, sequence)

import           Control.Concurrent.STM.Message
import           Control.Concurrent.STM.Notify
import           Control.Concurrent.STM.TMVar

-- GHCJS/VDom/Ophelia
import           GHCJS.Foreign
import           GHCJS.Foreign.QQ
import           GHCJS.Marshal
import           GHCJS.Types
import           GHCJS.VDOM
import qualified JavaScript.Canvas              as Canvas
import           Shakespeare.Dynamic.Components
import           Shakespeare.Dynamic.Event
import           Shakespeare.Dynamic.Render
import qualified VDOM.Adapter                   as VDA

import           Control.Concurrent
import           Control.Monad                  (void, when, join)
import           Control.Monad.STM
import           Data.Text                      (Text)
import           Shakespeare.Ophelia
import           Text.Read

main :: IO ()
main = do
  putStrLn "Haskell loaded"
  addCustomEvent "canvasLoad"
  exportRunTankGauge

-- | Create a function accessible from other javascript
-- resources that is equivilent to runTankGaugeWidget(domNode, TankGaugeWidgetConfig)
exportRunTankGauge :: IO ()
exportRunTankGauge = do
  addCustomEvent "canvasLoad"
  cb <- asyncCallback2 NeverRetain $ \jsDomRef tankGaugeConfRef -> do
    mJsDom <- fromJSRef jsDomRef
    mTankGaugeConf <- fromJSRef tankGaugeConfRef
    res <- sequence $ liftA2 runTankGaugeWidget mJsDom mTankGaugeConf
    when (isNothing res) $ error $ "Incorrect arguments given to runTankGaugeWidget \n" ++ (show mTankGaugeConf)
  [js_| runTankGaugeWidget = `cb; |]



instance FromJSON TankGaugeWidgetConfig where
  parseJSON (Object v) = TankGaugeWidgetConfig <$> v .: "name" <*> v .: "height"
  parseJSON _ = empty

instance FromJSRef TankGaugeWidgetConfig where
  fromJSRef r = do
    name <- join <$> (traverse fromJSRef =<< getPropMaybe ("name" :: Text) r) :: IO (Maybe String)
    height <- join <$> (traverse fromJSRef =<< getPropMaybe ("height" :: Text) r) :: IO (Maybe Int)
    return $ (\n h -> TankGaugeWidgetConfig (Fired n) (Right h)) <$> name <*> height


runTankGaugeWidget :: DOMNode -> TankGaugeWidgetConfig -> IO ()
runTankGaugeWidget container config = do
  addCustomEvent "canvasLoad"
  tgConfig@(tgEnv, _) <- spawnIO $ config
  (smbtEnv, sbmtAddr) <- spawnIO $ Unfired
  tgs@(tgsEnv, _) <- spawnIO []
  tmContainer <- newEmptyTMVarIO
  forkTankGauge tmContainer
  _ <- forkIO $ onChange smbtEnv (\_ -> do
    mtg <- recvIO tgEnv
    attemptInsertTank mtg tgs
    )
  runDomI container notifyAll (tankGaugeConfig tmContainer tgConfig sbmtAddr <$> tgsEnv)

addCss :: String -> IO ()
addCss str = [js_|
var ss = document.createElement("link");
ss.type = "text/css";
ss.rel = "stylesheet";
ss.href = `str;
document.getElementsByTagName("head")[0].appendChild(ss);
|]


data TankGaugeWidgetConfig = TankGaugeWidgetConfig {
  tankGaugeWidgetName   :: Event String
, tankGaugeWidgetHeight :: Either String Int
} deriving (Eq, Show)

data TankGaugeConfig = TankGaugeConfig {
  tankGaugeName   :: String
, tankGaugeHeight :: Int
} deriving (Eq, Show)


attemptInsertTank :: TankGaugeWidgetConfig -> STMMailbox ([TankGaugeConfig]) -> IO ()
attemptInsertTank (TankGaugeWidgetConfig eName eHeight) (env, addr) = case (orEmpty eName) of
                                                                        Unfired -> [js_|alert("Unable to add tank because there is no name")|]
                                                                        Fired name -> case eHeight of
                                                                                        (Left err) -> [js_|alert(`err)|]
                                                                                        (Right h) -> do
                                                                                                        xs <- recvIO env
                                                                                                        void $ sendIO addr $ (TankGaugeConfig name h):xs
  where orEmpty Unfired = Unfired
        orEmpty (Fired "") = Unfired
        orEmpty (Fired x) = Fired x


setName :: TankGaugeWidgetConfig -> String -> TankGaugeWidgetConfig
setName tg name = tg {tankGaugeWidgetName = Fired name}

setTankHeight :: TankGaugeWidgetConfig -> String -> TankGaugeWidgetConfig
setTankHeight tg heightStr = case readMaybe heightStr of
                                (Just h) -> tg {tankGaugeWidgetHeight = Right h}
                                Nothing -> tg {tankGaugeWidgetHeight = Left "Unable to parse height"}


modifyTankHeight :: STMMailbox TankGaugeWidgetConfig -> String -> Message Bool
modifyTankHeight mb = modifyMailbox mb setTankHeight

modifyTankName :: STMMailbox TankGaugeWidgetConfig -> String -> Message Bool<commit_msg>Fixed message send result type for new version of stm-notify<commit_after>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

{-
  Straight stolt on from virtual-dom
  virtual-dom bindings demo, rendering a large pixel grid with a bouncing red
  square. the step and patch are calculated asynchronously, the update is
  batched in an animation frame
 -}


module Main where

import           Data.Aeson
import           TankGauge
-- Base
import           Control.Applicative
import           Data.Maybe
import           Data.Traversable
-- import           Pipes.Concurrent
import           Prelude                        hiding (div, sequence)

import           Control.Concurrent.STM.Message
import           Control.Concurrent.STM.Notify
import           Control.Concurrent.STM.TMVar

-- GHCJS/VDom/Ophelia
import           GHCJS.Foreign
import           GHCJS.Foreign.QQ
import           GHCJS.Marshal
import           GHCJS.Types
import           GHCJS.VDOM
import qualified JavaScript.Canvas              as Canvas
import           Shakespeare.Dynamic.Components
import           Shakespeare.Dynamic.Event
import           Shakespeare.Dynamic.Render
import qualified VDOM.Adapter                   as VDA

import           Control.Concurrent
import           Control.Monad                  (void, when, join)
import           Control.Monad.STM
import           Data.Text                      (Text)
import           Shakespeare.Ophelia
import           Text.Read

main :: IO ()
main = do
  putStrLn "Haskell loaded"
  addCustomEvent "canvasLoad"
  exportRunTankGauge

-- | Create a function accessible from other javascript
-- resources that is equivilent to runTankGaugeWidget(domNode, TankGaugeWidgetConfig)
exportRunTankGauge :: IO ()
exportRunTankGauge = do
  addCustomEvent "canvasLoad"
  cb <- asyncCallback2 NeverRetain $ \jsDomRef tankGaugeConfRef -> do
    mJsDom <- fromJSRef jsDomRef
    mTankGaugeConf <- fromJSRef tankGaugeConfRef
    res <- sequence $ liftA2 runTankGaugeWidget mJsDom mTankGaugeConf
    when (isNothing res) $ error $ "Incorrect arguments given to runTankGaugeWidget \n" ++ (show mTankGaugeConf)
  [js_| runTankGaugeWidget = `cb; |]



instance FromJSON TankGaugeWidgetConfig where
  parseJSON (Object v) = TankGaugeWidgetConfig <$> v .: "name" <*> v .: "height"
  parseJSON _ = empty

instance FromJSRef TankGaugeWidgetConfig where
  fromJSRef r = do
    name <- join <$> (traverse fromJSRef =<< getPropMaybe ("name" :: Text) r) :: IO (Maybe String)
    height <- join <$> (traverse fromJSRef =<< getPropMaybe ("height" :: Text) r) :: IO (Maybe Int)
    return $ (\n h -> TankGaugeWidgetConfig (Fired n) (Right h)) <$> name <*> height


runTankGaugeWidget :: DOMNode -> TankGaugeWidgetConfig -> IO ()
runTankGaugeWidget container config = do
  addCustomEvent "canvasLoad"
  tgConfig@(tgEnv, _) <- spawnIO $ config
  (smbtEnv, sbmtAddr) <- spawnIO $ Unfired
  tgs@(tgsEnv, _) <- spawnIO []
  tmContainer <- newEmptyTMVarIO
  forkTankGauge tmContainer
  _ <- forkIO $ onChange smbtEnv (\_ -> do
    mtg <- recvIO tgEnv
    attemptInsertTank mtg tgs
    )
  runDomI container notifyAll (tankGaugeConfig tmContainer tgConfig sbmtAddr <$> tgsEnv)

addCss :: String -> IO ()
addCss str = [js_|
var ss = document.createElement("link");
ss.type = "text/css";
ss.rel = "stylesheet";
ss.href = `str;
document.getElementsByTagName("head")[0].appendChild(ss);
|]


data TankGaugeWidgetConfig = TankGaugeWidgetConfig {
  tankGaugeWidgetName   :: Event String
, tankGaugeWidgetHeight :: Either String Int
} deriving (Eq, Show)

data TankGaugeConfig = TankGaugeConfig {
  tankGaugeName   :: String
, tankGaugeHeight :: Int
} deriving (Eq, Show)


attemptInsertTank :: TankGaugeWidgetConfig -> STMMailbox ([TankGaugeConfig]) -> IO ()
attemptInsertTank (TankGaugeWidgetConfig eName eHeight) (env, addr) = case (orEmpty eName) of
                                                                        Unfired -> [js_|alert("Unable to add tank because there is no name")|]
                                                                        Fired name -> case eHeight of
                                                                                        (Left err) -> [js_|alert(`err)|]
                                                                                        (Right h) -> do
                                                                                                        xs <- recvIO env
                                                                                                        void $ sendIO addr $ (TankGaugeConfig name h):xs
  where orEmpty Unfired = Unfired
        orEmpty (Fired "") = Unfired
        orEmpty (Fired x) = Fired x


setName :: TankGaugeWidgetConfig -> String -> TankGaugeWidgetConfig
setName tg name = tg {tankGaugeWidgetName = Fired name}

setTankHeight :: TankGaugeWidgetConfig -> String -> TankGaugeWidgetConfig
setTankHeight tg heightStr = case readMaybe heightStr of
                                (Just h) -> tg {tankGaugeWidgetHeight = Right h}
                                Nothing -> tg {tankGaugeWidgetHeight = Left "Unable to parse height"}


modifyTankHeight :: STMMailbox TankGaugeWidgetConfig -> String -> Message ()
modifyTankHeight mb = modifyMailbox mb setTankHeight

modifyTankName :: STMMailbox TankGaugeWidgetConfig -> String -> Message ()
{'fraction_non_alphanumeric': 0.08051996633311512, 'fraction_numerical': 0.0005611147479659591, 'mean_word_length': 2.1114343904567936, 'pattern_counts': {'":': 0, '<': 51, '<?xml version=': 0, '>': 61, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 46, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7146804', 'n_tokens_mistral': 3007, 'n_tokens_neox': 2910, 'n_words': 834}