halogen-websocket-ipc-playzone/drop/ArrayBufferStuff.purs

module Main where

import Prelude

import Control.Monad.Trans.Class (lift)
import Control.Monad.Except (ExceptT(ExceptT), withExceptT)
import Data.Array as Array
import Data.Either (Either(Left, Right), either, note, hush)
import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe)
import Data.String as String
import Data.Traversable (for, for_, traverse, traverse_)
import Effect (Effect)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import Effect.Exception as Exception
import TryPureScript (Doc, Inline, render, withConsole)
import Unsafe.Coerce (unsafeCoerce)

import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer
import Data.ArrayBuffer.Builder as Builder
import Data.ArrayBuffer.Cast (toUint8Array) as Cast
import Data.ArrayBuffer.DataView as DataView
import Data.ArrayBuffer.Typed as Typed
import Data.ArrayBuffer.Types (ArrayBuffer, ArrayView, DataView, Int32)
import Parsing (ParserT(..), ParseError(..), runParserT)
import Parsing as Parsing
import Parsing.DataView (anyInt32be, takeN) as Parsing.DataView
import Web.Encoding.TextDecoder as TextDecoder
import Web.Encoding.TextEncoder as TextEncoder
import Web.Encoding.UtfLabel as UtfLabel


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

program :: Effect Unit
program = do
  comment "ArrayBuffer stuff"
  
  -- Going to try a round-trip version of the
  -- example in the `purescript-arraybuffer-builder`
  -- README file:
  
  let
    input :: String
    input = "🦝 ééàà"
  
  comment $ "We'll try to roundtrip the following: " <> input
  
  -- First the ArrayBuffer builder half of the roundtrip:
  arrayBuffer <- examplePutStringUtf8 input
  

  -- Then parsing the ArrayBuffer back for the second half of the roundtrip:
  exampleParseUtf8 arrayBuffer >>= case _ of
    
    Left parseError -> do
      comment "Failure :("
      Console.logShow parseError
      
    Right string -> do
      comment "SUCCESS!"
      logString $ "You should see the input string here: " <> string


--------------------------------------------------------------------------------
-- BUILDER example


-- modified example from the README at:
--    https://pursuit.purescript.org/packages/purescript-arraybuffer-builder/3.1.0
--
-- as the 'Encode a String as UTF8 with a length prefix into our Builder'
examplePutStringUtf8 :: String -> Effect ArrayBuffer
examplePutStringUtf8 s = Builder.execPutM do
  textEncoder <- liftEffect TextEncoder.new
  let stringbuf = Typed.buffer $ TextEncoder.encode s textEncoder
  -- Put a 32-bit big-endian length for the utf8 string, in bytes.
  Builder.putInt32be $ ArrayBuffer.byteLength stringbuf
  Builder.putArrayBuffer stringbuf


--------------------------------------------------------------------------------
-- PARSER example
-- modified example from the README at:
--    https://pursuit.purescript.org/packages/purescript-parsing-dataview/3.2.4
--
-- as the 'Parse a UTF-8 String with a length prefix' example
exampleParseUtf8 :: ArrayBuffer -> Effect (Either ParseError String)
exampleParseUtf8 arrayBuffer = do
  
  textDecoder <- TextDecoder.new UtfLabel.utf8
  
  let
    dataView = DataView.whole arrayBuffer
  
  runParserT dataView do
    -- First parse a 32-bit big-endian length prefix for the length
    -- of the UTF-8 string in bytes.
    length <- Parsing.DataView.anyInt32be
    stringview <- Parsing.DataView.takeN length
    stringarray <- lift $ liftEffect $ Cast.toUint8Array stringview
    hoistEffectParserT $ TextDecoder.decode stringarray textDecoder
  
 
-- I didn't like how the `purescript-parsing-dataview` handled that
-- part of the example, so made this to help:
hoistEffectParserT
  :: forall a
   . Effect a
  -> ParserT DataView Effect a
hoistEffectParserT
  = Exception.try
  >>> ExceptT
  >>> withExceptT Exception.message
  >>> Parsing.liftExceptT




--------------------------------------------------------------------------------
-- I/O

main :: Effect Unit
main = withConsole program >>= renderWithCSS cssArray


--------------------------------------------------------------------------------
-- Utilities (helping me in the absence of a TryPureScript dark mode)


renderWithCSS :: Array String -> Doc -> Effect Unit
renderWithCSS css htmlDoc = render doc
  where
  doc :: Doc
  doc = mkDoc (tagWithStyle' "div" css (unDoc htmlDoc))

cssArray :: Array String
cssArray =
  [ "display: block"
  , "flex-direction: column"
  , "justify-content: space-between"
  , "height: calc(100vh - 30px)"
  , "background: #282c34"
  , "color: #e06c75"
  , "font-family: 'Consolas'"
  , "padding: 5px 20px 5px 20px"
  ]

logCustom
  :: String
  -> String
  -> Array String
  -> String
  -> Effect Unit
logCustom tag color css = Console.log <<< tagWithStyle' tag css'
  where
  css' = ["color: "<> color] <> css

logString :: String -> Effect Unit
logString = logCustom "span" "#89ca78" []

logShowString :: forall val. Show val => val -> Effect Unit
logShowString = logCustom "span" "#89ca78" [] <<< show

comment :: String -> Effect Unit
comment = logCustom "span" "#7f848e" css <<< ("\n-- " <> _)
  where
  css = [ "font-style: italic" ]

mkDoc :: String -> Doc
mkDoc = unsafeCoerce

unDoc :: Doc -> String
unDoc = unsafeCoerce

unInline :: Inline -> String
unInline = unsafeCoerce

mkInline :: String -> Inline
mkInline = unsafeCoerce

tagWithStyle :: String -> String -> Array String -> String -> String
tagWithStyle open close css html
  =  "<" <> open <> " style=\"" <> String.joinWith "; " css <> "\">"
  <> html
  <> "</" <> close <> ">"

tagWithStyle' :: String -> Array String -> String -> String
tagWithStyle' open = tagWithStyle open open