module Debug.Draw
  ( traceDrawId
  , traceDraw
  , traceDrawIO
  , clearLayer
  , clear



  --------------------------------------------------------------------------------
  , debugClient
  , clientDrawLayer

  --------------------------------------------------------------------------------
  , draw'
  ) where


import HGeometry.Miso.Svg
import Debugger.API
import Network.HTTP.Client (newManager, defaultManagerSettings)
import System.IO.Unsafe (unsafePerformIO)
import           Servant.Client ( ClientM, runClientM, ClientEnv, mkClientEnv
                                , BaseUrl(..), client, Scheme(..)
                                )
import Data.Text.Encoding (decodeUtf8Lenient)
import Miso (View, ms, text, toMisoString)
import Data.ByteString (ByteString, toStrict)
import Data.ByteString.Char8 (pack)
import Servant.API
import Data.Proxy
import Miso.Html.Render

--------------------------------------------------------------------------------

-- | Trace and draw
traceDrawId         :: (Show a, Drawable a) => LayerName -> a -> a
traceDrawId :: forall a. (Show a, Drawable a) => LayerName -> a -> a
traceDrawId LayerName
layer a
a = LayerName -> a -> a -> a
forall a b. (Show a, Drawable a) => LayerName -> a -> b -> b
traceDraw LayerName
layer a
a a
a

-- | Trace and draw an a on the given layer, while returning a b.
--
-- this will add to the current layer
traceDraw           :: (Show a, Drawable a) => LayerName -> a -> b -> b
traceDraw :: forall a b. (Show a, Drawable a) => LayerName -> a -> b -> b
traceDraw LayerName
layer a
a b
b = IO b -> b
forall a. IO a -> a
unsafePerformIO (IO b -> b) -> IO b -> b
forall a b. (a -> b) -> a -> b
$ LayerName -> a -> b -> IO b
forall a b. (Show a, Drawable a) => LayerName -> a -> b -> IO b
traceDrawIO LayerName
layer a
a b
b
{-# NOINLINE traceDraw #-}

-- | Implementation of traceDraw
traceDrawIO           :: (Show a,Drawable a) => LayerName -> a -> b -> IO b
traceDrawIO :: forall a b. (Show a, Drawable a) => LayerName -> a -> b -> IO b
traceDrawIO LayerName
layer a
a b
b = b
b b -> IO () -> IO b
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ClientM () -> IO ()
forall a. ClientM a -> IO ()
debugClient ((LayerName, LayerName, Drawing) -> ClientM ()
clientDrawLayer (LayerName
layer,a -> LayerName
forall a. Show a => a -> LayerName
show a
a, a -> Drawing
forall a. Drawable a => a -> Drawing
draw' a
a))

-- | Clears a particular layer
clearLayer      :: LayerName -> IO ()
clearLayer :: LayerName -> IO ()
clearLayer LayerName
layer = ClientM () -> IO ()
forall a. ClientM a -> IO ()
debugClient (ClientM () -> IO ()) -> ClientM () -> IO ()
forall a b. (a -> b) -> a -> b
$ LayerName -> ClientM ()
clientClearLayer LayerName
layer

-- | Clears all layers
clear :: IO ()
clear :: IO ()
clear = ClientM () -> IO ()
forall a. ClientM a -> IO ()
debugClient ClientM ()
clientClear

--------------------------------------------------------------------------------

draw' :: Drawable a => a -> Drawing
draw' :: forall a. Drawable a => a -> Drawing
draw' = Text -> Drawing
Drawing (Text -> Drawing) -> (a -> Text) -> a -> Drawing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall str. ToMisoString str => str -> Text
toMisoString (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
toStrict (LazyByteString -> ByteString)
-> (a -> LazyByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View (ZonkAny 0) (ZonkAny 1) -> LazyByteString
forall a. ToHtml a => a -> LazyByteString
toHtml (View (ZonkAny 0) (ZonkAny 1) -> LazyByteString)
-> (a -> View (ZonkAny 0) (ZonkAny 1)) -> a -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [Attribute (ZonkAny 1)] -> View (ZonkAny 0) (ZonkAny 1))
-> [Attribute (ZonkAny 1)] -> a -> View (ZonkAny 0) (ZonkAny 1)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> [Attribute (ZonkAny 1)] -> View (ZonkAny 0) (ZonkAny 1)
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model. a -> [Attribute action] -> View model action
draw []

--------------------------------------------------------------------------------
-- * The client

ClientM Drawings
clientDrawing
  :<|> (LayerName, LayerName, Drawing) -> ClientM ()
clientDrawLayer
  :<|> LayerName -> ClientM ()
clientClearLayer
  :<|> ClientM ()
clientClear
  = Proxy API -> Client ClientM API
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @API)

-- type Client = ReaderT ClientEnv IO

-- | Run some client action; just print the error if it fails somehow.
debugClient     :: ClientM a -> IO ()
debugClient :: forall a. ClientM a -> IO ()
debugClient ClientM a
act = ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
act ClientEnv
debugClientEnv IO (Either ClientError a)
-> (Either ClientError a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left ClientError
err -> LayerName -> IO ()
putStrLn (LayerName -> IO ()) -> LayerName -> IO ()
forall a b. (a -> b) -> a -> b
$ LayerName
"error: " LayerName -> LayerName -> LayerName
forall a. Semigroup a => a -> a -> a
<> ClientError -> LayerName
forall a. Show a => a -> LayerName
show ClientError
err
                    Right a
_  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The default debug clientEnv
debugClientEnv :: ClientEnv
debugClientEnv :: ClientEnv
debugClientEnv = IO ClientEnv -> ClientEnv
forall a. IO a -> a
unsafePerformIO IO ClientEnv
debugClientEnv'
{-# NOINLINE debugClientEnv #-}

-- | Creates a default ClientEnv
debugClientEnv' :: IO ClientEnv
debugClientEnv' :: IO ClientEnv
debugClientEnv' = do mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
                     pure $ mkClientEnv mgr defaultBaseUrl

defaultBaseUrl :: BaseUrl
defaultBaseUrl :: BaseUrl
defaultBaseUrl = Scheme -> LayerName -> Int -> LayerName -> BaseUrl
BaseUrl Scheme
Http LayerName
defaultHost Int
defaultPort LayerName
""