diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ += WIP Developer Tools + +Chrome extension for niceness diff --git a/Shpadoinkle-developer-tools.cabal b/Shpadoinkle-developer-tools.cabal new file mode 100644 --- /dev/null +++ b/Shpadoinkle-developer-tools.cabal @@ -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 diff --git a/Shpadoinkle/DeveloperTools.hs b/Shpadoinkle/DeveloperTools.hs new file mode 100644 --- /dev/null +++ b/Shpadoinkle/DeveloperTools.hs @@ -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