Shpadoinkle-debug-0.0.0.1: Shpadoinkle/Debug.hs

{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}


module Shpadoinkle.Debug
  ( LogJS (..)
  , Trapper (..)
  , askJSM
  ) where


import           Control.Lens
import           Data.Aeson                  (ToJSON, encode)
import           Data.Kind
import           Data.Text
import           Data.Text.Lazy              (toStrict)
import           Data.Text.Lazy.Encoding
import           Language.Javascript.JSaddle
import           System.IO.Unsafe            (unsafePerformIO)


default (Data.Text.Text)


class LogJS (c :: Type -> Constraint) where
  logJS :: c a => a -> JSM ()

instance LogJS ToJSON where
  logJS a = do
    console <- jsg "console"
    json <- jsg "JSON"
    parsed <- json ^. js1 "parse" (toStrict . decodeUtf8 $ encode a)
    () <$ console ^. js1 "log" parsed

instance LogJS Show where
  logJS a = do
    console <- jsg "console"
    () <$ console ^. js1 "log" (pack $ show a)

instance LogJS ToJSVal where
  logJS a = do
    console <- jsg "console"
    () <$ console ^. js1 "log" (toJSVal a)


class LogJS c => Trapper c where
  trapper :: c a => JSContextRef -> a -> a
  trapper ctx x = unsafePerformIO $ runJSM (x <$ logJS @c x) ctx
  {-# NOINLINE trapper #-}


instance Trapper ToJSON
instance Trapper Show
instance Trapper ToJSVal