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

190 lines
5.5 KiB
Plaintext
Raw Normal View History

2023-05-20 00:49:12 +02:00
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