packages feed

Shpadoinkle-developer-tools (empty) → 0.0.0.1

raw patch · 5 files changed

+333/−0 lines, 5 filesdep +Shpadoinkledep +Shpadoinkle-backend-pardiffdep +Shpadoinkle-html

Dependencies added: Shpadoinkle, Shpadoinkle-backend-pardiff, Shpadoinkle-html, base, containers, jsaddle, lens, pretty-show, stm, text, time, unliftio

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Shpadoinkle Developer Tools aka S11 Developer Tools+Copyright © 2020 Isaac Shapira+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+ * Neither the name of Shpadoinkle nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Main where+++import           Control.Lens+import           Control.Monad               (void, when)+import           Control.Monad.IO.Class      (liftIO)+import           Data.Map                    as Map (Map, insert, lookup,+                                                     toDescList)+import           Data.Text                   (Text, pack, unpack)+import           Data.Time                   (UTCTime, defaultTimeLocale,+                                              formatTime, getCurrentTime)+import           Language.Javascript.JSaddle (FromJSVal (fromJSVal), JSM,+                                              MonadJSM, fun, js, js1, js2, jsg,+                                              liftJSM, obj, strictEqual, (<#))+import           Prelude                     hiding (div, span)+import qualified Text.Show.Pretty            as Pretty+import           UnliftIO                    (TVar, atomically, modifyTVar,+                                              newTVarIO)++import           Shpadoinkle                 (Html, flagProp, shpadoinkle, text)+import           Shpadoinkle.Backend.ParDiff (runParDiff)+import           Shpadoinkle.Html+import           Shpadoinkle.Run             (runJSorWarp)+++default (Text)+++newtype History = History { unHistory :: Text }+  deriving (Eq, Ord, Show)+++data Model = Model+  { _history :: Map UTCTime History+  , _active  :: Maybe UTCTime+  , _sync    :: Bool+  } deriving (Eq, Show)+makeLenses ''Model+++emptyModel :: Model+emptyModel = Model mempty Nothing True+++listenForOutput :: TVar Model -> JSM ()+listenForOutput model = void $ jsg "chrome" ^. (js "runtime" . js "onMessage" . js1 "addListener" (fun $ \ _ _ args -> do+  let x = Prelude.head args+  t <- x ^. js "type"+  isRight <- strictEqual t "shpadoinkle_output_state"+  when isRight $ do+    msg <- x ^. js "msg"+    now <- liftIO getCurrentTime+    history' <- maybe (error "how could this not be a string") History <$> fromJSVal msg+    atomically . modifyTVar model $ heard now history'))+++heard :: UTCTime -> History -> Model -> Model+heard now history' m = m & history %~ insert now history' &+  case m ^. active of+    Just _ | m ^. sync -> active ?~ now+    Nothing            -> active ?~ now+    Just _             -> id+++row :: MonadJSM m => Maybe UTCTime -> UTCTime -> History -> Html m Model+row sel k history' = div "record"+  [ div [ className "time"+        , class' [("active", sel == Just k)]+        ]+     [ span_ [ text . pack $ formatTime defaultTimeLocale "%X%Q" k ]+     , button [ onClick $ (sync .~ False) . (active ?~ k) ] [ "Inspect" ]+     , button [ onClickM_ . liftJSM $ sendHistory history' ] [ "Send" ]+     ]+  ]+++sendHistory :: History -> JSM ()+sendHistory (History history') = void $ do+  tabId <- jsg "chrome" ^. (js "devtools" . js "inspectedWindow" . js "tabId")++  msg <- obj+  (msg <# "type") "shpadoinkle_set_state"+  (msg <# "msg") history'++  void $ jsg "chrome" ^. (js "tabs" . js2 "sendMessage" tabId msg)+++prettyHtml :: Int -> Pretty.Value -> Html m a+prettyHtml depth = \case+  Pretty.Con con [] -> div "con-uniary" $ string con+  Pretty.Con con slots -> details [ className "con-wrap", ("open", flagProp $ depth < 3) ]+    [ summary "con" $ string con+    , div (withDepth "con-children") $ prettyHtml (depth + 1) <$> slots+    ]+  Pretty.Rec rec fields ->+    details (withDepth "rec-wrap")+    [ summary "rec" $ string rec+    , dl "rec" $ (\(n, v)->+        [ dt_ $ string $ n <> " = "+        , dd_ [ prettyHtml (depth + 1) v ]+        ]) =<< fields+    ]+  Pretty.InfixCons _ _ -> text "Infix Constructors are not currently supported"+  Pretty.Neg x     -> div "neg" [ "¬", prettyHtml depth x ]+  Pretty.Ratio n d -> div "ratio" [ prettyHtml depth n, "/", prettyHtml depth d ]+  Pretty.Tuple xs  -> prettyHtml depth $ Pretty.Con "(,)" xs+  Pretty.List []   -> prettyHtml depth $ Pretty.Con "[]" []+  Pretty.List xs   -> ul "list" $ li_.pure.prettyHtml (depth +1) <$> xs+  Pretty.String ss -> div "string" $ string ss+  Pretty.Float n   -> div "float" $ string n+  Pretty.Integer n -> div "integer" $ string n+  Pretty.Char c    -> div "char" $ string c+  where string = pure . text . pack+        withDepth x = [ class' [ x, "depth-" <> pack (show depth) ] ]+++syncState :: Model -> Model+syncState m =+  m & sync .~ True & active .~ (m ^. history . to (g . toDescList))+  where g ((x,_):_) = Just x+        g _         = Nothing+++panel :: MonadJSM m => Model -> Html m Model+panel m = div "wrapper"+  [ div "current-state" $ case _active m >>= flip Map.lookup (_history m) of+      Just history' -> [ maybe (text "failed to parse value") (prettyHtml 0) . Pretty.parseValue . unpack $ unHistory history' ]+      _             -> [ "No State" ]+  , div "history" $ button+    [ onClick syncState+    , className "sync-button"+    , class' [ ("sync", m ^. sync) ]+    ] [ "Sync State" ] : (book <> [clear])+  ]+  where book = uncurry (m ^. active . to row) <$> Map.toDescList (m ^. history)+        clear = a [ className "clear", onClick $ const emptyModel ] [ "Clear History" ]+++app :: JSM ()+app = do+  model <- liftIO $ newTVarIO emptyModel+  listenForOutput model+  shpadoinkle id runParDiff emptyModel model panel getBody+++main :: IO ()+main = runJSorWarp 8080 app
+ README.md view
@@ -0,0 +1,3 @@+= WIP Developer Tools++Chrome extension for niceness
+ Shpadoinkle-developer-tools.cabal view
@@ -0,0 +1,78 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a1087083f64a24e1a337267f5340d0e7ed3089e4156374e0aef1cd1258fc313d++name:           Shpadoinkle-developer-tools+version:        0.0.0.1+synopsis:       Chrome extension to aide in development+description:    A chrome extension to make developing Shpadoinkle applications easier+category:       Web+author:         Isaac Shapira+maintainer:     fresheyeball@protonmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://gitlab.com/fresheyeball/Shpadoinkle.git++flag development+  description: Add instrumentation for development purposes.+  manual: True+  default: False++library+  exposed-modules:+      Shpadoinkle.DeveloperTools+  other-modules:+      Main+      Paths_Shpadoinkle_developer_tools+  hs-source-dirs:+      ./.+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+  build-depends:+      Shpadoinkle+    , Shpadoinkle-backend-pardiff+    , Shpadoinkle-html+    , base >=4.12.0 && <4.16+    , containers+    , jsaddle+    , lens+    , pretty-show+    , stm+    , text+    , time+    , unliftio+  if flag(development)+    cpp-options: -DDEVELOPMENT+  default-language: Haskell2010++executable devtools+  main-is: Main.hs+  other-modules:+      Shpadoinkle.DeveloperTools+  hs-source-dirs:+      ./.+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+  ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2+  build-depends:+      Shpadoinkle+    , Shpadoinkle-backend-pardiff+    , Shpadoinkle-html+    , base >=4.12.0 && <4.16+    , containers+    , jsaddle+    , lens+    , pretty-show+    , stm+    , text+    , time+    , unliftio+  default-language: Haskell2010
+ Shpadoinkle/DeveloperTools.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE RankNTypes           #-}+#ifdef DEVELOPMENT+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+#endif+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+++module Shpadoinkle.DeveloperTools (withDeveloperTools) where+++import           Language.Javascript.JSaddle+import           UnliftIO+#ifdef DEVELOPMENT+import           Control.Lens+import           Control.Monad+import           Control.Monad.STM           (retry)+import           UnliftIO.Concurrent+#endif+++default (JSString)+++#ifdef DEVELOPMENT+withDeveloperTools :: forall a. Eq a => Read a => Show a => TVar a -> JSM ()+withDeveloperTools x = do+  i' <- readTVarIO x+  y  <- newTVarIO i'+  outputState i'+  syncPoint+  listenForSetState x+  () <$ forkIO (f y)+  where+  f y = do+    x' <- atomically $ do+      y' :: a <- readTVar y+      x' :: a <- readTVar x+      if x' == y' then retry else x' <$ writeTVar y x'+    outputState x'+    f y+++outputState :: forall a. Show a => a -> JSM ()+outputState x = void . (try :: forall b. JSM b -> JSM (Either SomeException b)) $ do+  o <- obj+  (o <# "type") "shpadoinkle_output_state"+  (o <# "msg") $ toJSString $ show x+  jsg "window" ^. js2 "postMessage" o "*"+++listenForSetState :: forall a. Read a => TVar a -> JSM ()+listenForSetState model = void $ jsg "window" ^. js2 "addEventListener" "message" (fun $ \_ _ args -> do+    let e = Prelude.head args+    isWindow <- strictEqual (e ^. js "source") (jsg "window")+    d <- e ^. js "data"+    isRightType <- strictEqual (d ^. js "type") "shpadoinkle_set_state"+    msg <- fromJSVal =<< (d ^. js "msg")+    case msg of+      Just msg' | isWindow && isRightType ->+        atomically . writeTVar model $ read msg'+      _ -> return ())++#else+withDeveloperTools :: forall a. Eq a => Read a => Show a => TVar a -> JSM ()+withDeveloperTools = const $ pure ()+#endif