{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Shpadoinkle.Console (
LogJS (..), Assert (..), Trapper (..), askJSM
, log, debug, info, warn
, table
, TimeLabel(..), time, timeEnd
, ToJSVal, ToJSON
) where
import Control.Lens ((^.))
import Data.Aeson (ToJSON, encode)
import Data.Kind (Constraint, Type)
import Data.String (IsString)
import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Language.Javascript.JSaddle (JSContextRef, MonadJSM,
ToJSVal (toJSVal), askJSM, js1,
js2, jsg, liftJSM, runJSM)
import Prelude hiding (log)
import System.IO.Unsafe (unsafePerformIO)
default (Text)
class LogJS (c :: Type -> Constraint) where
logJS :: MonadJSM m => c a => Text -> a -> m ()
instance LogJS ToJSON where
logJS :: Text -> a -> m ()
logJS Text
t a
a = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
JSVal
json <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"JSON"
JSVal
parsed <- JSVal
json JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> Text -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
"parse" (Text -> Text
toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a)
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> JSVal -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
t JSVal
parsed
instance LogJS Show where
logJS :: Text -> a -> m ()
logJS Text
t a
a = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> Text -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
t (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
a)
instance LogJS ToJSVal where
logJS :: Text -> a -> m ()
logJS Text
t a
a = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> JSM JSVal -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
t (a -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal a
a)
class LogJS c => Trapper c where
trapper :: c a => JSContextRef -> a -> a
trapper JSContextRef
ctx a
x = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ JSM a -> JSContextRef -> IO a
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM (a
x a -> JSM () -> JSM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> JSM ()
forall (c :: * -> Constraint) a (m :: * -> *).
(MonadJSM m, LogJS c, c a) =>
a -> m ()
debug @c a
x) JSContextRef
ctx
{-# NOINLINE trapper #-}
instance Trapper ToJSON
instance Trapper Show
instance Trapper ToJSVal
class Assert (c :: Type -> Constraint) where
assert :: MonadJSM m => c a => Bool -> a -> m ()
instance Assert ToJSON where
assert :: Bool -> a -> m ()
assert Bool
b a
x = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
JSVal
json <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"JSON"
JSVal
parsed <- JSVal
json JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> Text -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
"parse" (Text -> Text
toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
x)
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> JSM JSVal -> JSVal -> JSF
forall name a0 a1.
(ToJSString name, ToJSVal a0, ToJSVal a1) =>
name -> a0 -> a1 -> JSF
js2 Text
"assert" (Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
b) JSVal
parsed
instance Assert Show where
assert :: Bool -> a -> m ()
assert Bool
b a
x = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> JSM JSVal -> Text -> JSF
forall name a0 a1.
(ToJSString name, ToJSVal a0, ToJSVal a1) =>
name -> a0 -> a1 -> JSF
js2 Text
"assert" (Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
b) (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x)
instance Assert ToJSVal where
assert :: Bool -> a -> m ()
assert Bool
b a
x = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> JSM JSVal -> JSM JSVal -> JSF
forall name a0 a1.
(ToJSString name, ToJSVal a0, ToJSVal a1) =>
name -> a0 -> a1 -> JSF
js2 Text
"assert" (Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
b) (a -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal a
x)
table :: MonadJSM m => ToJSON a => [a] -> m ()
table :: [a] -> m ()
table = Text -> [a] -> m ()
forall (c :: * -> Constraint) (m :: * -> *) a.
(LogJS c, MonadJSM m, c a) =>
Text -> a -> m ()
logJS @ToJSON Text
"table"
log :: forall c a m. MonadJSM m => LogJS c => c a => a -> m ()
log :: a -> m ()
log = Text -> a -> m ()
forall (c :: * -> Constraint) (m :: * -> *) a.
(LogJS c, MonadJSM m, c a) =>
Text -> a -> m ()
logJS @c Text
"log"
warn :: forall c a m. MonadJSM m => LogJS c => c a => a -> m ()
warn :: a -> m ()
warn = Text -> a -> m ()
forall (c :: * -> Constraint) (m :: * -> *) a.
(LogJS c, MonadJSM m, c a) =>
Text -> a -> m ()
logJS @c Text
"warn"
info :: forall c a m. MonadJSM m => LogJS c => c a => a -> m ()
info :: a -> m ()
info = Text -> a -> m ()
forall (c :: * -> Constraint) (m :: * -> *) a.
(LogJS c, MonadJSM m, c a) =>
Text -> a -> m ()
logJS @c Text
"info"
debug :: forall c a m. MonadJSM m => LogJS c => c a => a -> m ()
debug :: a -> m ()
debug = Text -> a -> m ()
forall (c :: * -> Constraint) (m :: * -> *) a.
(LogJS c, MonadJSM m, c a) =>
Text -> a -> m ()
logJS @c Text
"debug"
newtype TimeLabel = TimeLabel { TimeLabel -> Text
unTimeLabel :: Text }
deriving (TimeLabel -> TimeLabel -> Bool
(TimeLabel -> TimeLabel -> Bool)
-> (TimeLabel -> TimeLabel -> Bool) -> Eq TimeLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeLabel -> TimeLabel -> Bool
$c/= :: TimeLabel -> TimeLabel -> Bool
== :: TimeLabel -> TimeLabel -> Bool
$c== :: TimeLabel -> TimeLabel -> Bool
Eq, Eq TimeLabel
Eq TimeLabel
-> (TimeLabel -> TimeLabel -> Ordering)
-> (TimeLabel -> TimeLabel -> Bool)
-> (TimeLabel -> TimeLabel -> Bool)
-> (TimeLabel -> TimeLabel -> Bool)
-> (TimeLabel -> TimeLabel -> Bool)
-> (TimeLabel -> TimeLabel -> TimeLabel)
-> (TimeLabel -> TimeLabel -> TimeLabel)
-> Ord TimeLabel
TimeLabel -> TimeLabel -> Bool
TimeLabel -> TimeLabel -> Ordering
TimeLabel -> TimeLabel -> TimeLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimeLabel -> TimeLabel -> TimeLabel
$cmin :: TimeLabel -> TimeLabel -> TimeLabel
max :: TimeLabel -> TimeLabel -> TimeLabel
$cmax :: TimeLabel -> TimeLabel -> TimeLabel
>= :: TimeLabel -> TimeLabel -> Bool
$c>= :: TimeLabel -> TimeLabel -> Bool
> :: TimeLabel -> TimeLabel -> Bool
$c> :: TimeLabel -> TimeLabel -> Bool
<= :: TimeLabel -> TimeLabel -> Bool
$c<= :: TimeLabel -> TimeLabel -> Bool
< :: TimeLabel -> TimeLabel -> Bool
$c< :: TimeLabel -> TimeLabel -> Bool
compare :: TimeLabel -> TimeLabel -> Ordering
$ccompare :: TimeLabel -> TimeLabel -> Ordering
$cp1Ord :: Eq TimeLabel
Ord, Int -> TimeLabel -> ShowS
[TimeLabel] -> ShowS
TimeLabel -> String
(Int -> TimeLabel -> ShowS)
-> (TimeLabel -> String)
-> ([TimeLabel] -> ShowS)
-> Show TimeLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeLabel] -> ShowS
$cshowList :: [TimeLabel] -> ShowS
show :: TimeLabel -> String
$cshow :: TimeLabel -> String
showsPrec :: Int -> TimeLabel -> ShowS
$cshowsPrec :: Int -> TimeLabel -> ShowS
Show, String -> TimeLabel
(String -> TimeLabel) -> IsString TimeLabel
forall a. (String -> a) -> IsString a
fromString :: String -> TimeLabel
$cfromString :: String -> TimeLabel
IsString)
time :: MonadJSM m => TimeLabel -> m ()
time :: TimeLabel -> m ()
time (TimeLabel Text
l) = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> Text -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
"time" Text
l
timeEnd :: MonadJSM m => TimeLabel -> m ()
timeEnd :: TimeLabel -> m ()
timeEnd (TimeLabel Text
l) = JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
JSVal
console <- Text -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg Text
"console"
() () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ JSVal
console JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> Text -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 Text
"timeEnd" Text
l