This article counts for two! The first part is dedicated to new primitives that deal with array rank, the second to a completely new web interface for TinyAPL.
Like always, all code is available in a GitHub repository.
Updating to GHC 9.10.1
Not much to say, just changed all instances of base ^>=4.18.0.0 to base ^>=4.20.0.0 in tinyapl.cabal.
Fixing Roll
Last article I implemented Roll and ⎕seed, but had to scrap them last minute because it didn't compile on WASM! The fix is to roll our own global state for the generator instead of the default one, which uses a function that isn't supported by WASI.
module TinyAPL.Random
( random
, randomR
, setSeed )
where
import qualified System.Random as R
import Data.Time.Clock.POSIX
import System.IO.Unsafe
import Data.IORef
import Control.Monad.IO.Class
{-# NOINLINE theGenerator #-}
theGenerator :: IORef R.StdGen
theGenerator = unsafePerformIO $ getPOSIXTime >>= newIORef . R.mkStdGen . fromEnum
withTheGenerator :: (R.Random a, MonadIO m) => (R.StdGen -> (a, R.StdGen)) -> m a
withTheGenerator f = do
gen <- liftIO $ readIORef theGenerator
let (a, gen') = f gen
liftIO $ writeIORef theGenerator gen'
pure a
random :: (R.Random a, MonadIO m) => m a
random = withTheGenerator R.random
randomR :: (R.Random a, MonadIO m) => (a, a) -> m a
randomR = withTheGenerator . R.randomR
setSeed :: MonadIO m => Int -> m ()
setSeed s = liftIO $ writeIORef theGenerator $ R.mkStdGen s
Rank, Promote, Demote, Rerank
Rank is a function that returns the rank of an array:
rank :: MonadError Error m => Array -> m Natural
rank = pure . arrayRank
rank' :: MonadError Error m => Array -> m Array
rank' arr = scalar . Number . fromInteger . toInteger <$> rank arr
Promote increases the rank of an array by 1, introducing a leading axis of length 1:
promote :: MonadError Error m => Array -> m Array
promote arr = reshape (1 : map toInteger (arrayShape arr)) arr
Demote combines two leading axes by multiplying their length, and collapses vectors to scalars:
demote :: MonadError Error m => Array -> m Array
demote arr = case toInteger <$> arrayShape arr of
[] -> pure arr
[_] -> pure $ scalar $ head $ arrayContents arr
(a:b:ss) -> reshape (a * b : ss) arr
Rerank ties Promote and Demote together, promoting or demoting until an array has the specified rank:
rerank :: MonadError Error m => Natural -> Array -> m Array
rerank n arr =
if arrayRank arr == n then pure arr
else if arrayRank arr > n then demote arr >>= rerank n
else promote arr >>= rerank n
rerank' :: MonadError Error m => Array -> Array -> m Array
rerank' narr arr = do
let err = DomainError "Rerank left argument must be a scalar natural"
n <- asScalar err narr >>= asNumber err >>= asNat err
rerank n arr
At Rank
At Rank (which you might know from other APLs as just "Rank") is a conjunction which appies a function to cells of one or two arguments of a specified rank. Read more about it on the APL wiki.
First, parsing the right operand:
parseRank :: MonadError Error m => Array -> m (Integer, Integer, Integer)
parseRank arr = do
let err = DomainError "Rank or depth right operand must be a 1-, 2- or 3-element integer vector"
v <- asVector err arr >>= mapM (asNumber err >=> asInt err)
case v of
[d] -> pure (d, d, d)
[d, e] -> pure (e, d, e)
[d, e, f] -> pure (d, e, f)
_ -> throwError err
(You see a mention of "depth", At Depth is a planned primitive that acts similarly to At Rank but with, well, depth instead of rank.)
Monadic At Rank is implemented using a recursive strategy:
- if the rank of the argument is zero, we can't go deeper, so the function is applied to the array as a whole
- if the requested rank is greater than or equal to the array's rank, the function is applied to the array as a whole
- if the rank is negative one (which means "apply to major cells"), the function is — of course — applied to major cells
- otherwise, we recurse, applying At Rank on the major cells of the array and then building it back
atRank1 :: MonadError Error m => (Array -> m Array) -> Integer -> Array -> m Array
atRank1 f rank arr
| arrayRank arr == 0 = f arr
| rank >= 0 && toInteger (arrayRank arr) <= rank = f arr
| rank >= 0 = fromMajorCells <$> mapM (atRank1 f rank) (majorCells arr)
| rank == -1 = fromMajorCells <$> mapM f (majorCells arr)
| otherwise = fromMajorCells <$> mapM (atRank1 f $ rank + 1) (majorCells arr)
atRank1' :: MonadError Error m => (Array -> m Array) -> Array -> Array -> m Array
atRank1' f r y = do
(a, _, _) <- parseRank r
atRank1 f a y
Dyadic At Rank could be implemented with a similar recursive strategy, but @dzaima suggests a simpler way:
atRank2 :: MonadError Error m => (Array -> Array -> m Array) -> (Integer, Integer) -> Array -> Array -> m Array
atRank2 f (ra, rb) a b = do
-- @dzaima (in fact, {a b c←⌽3⍴⌽⍵⍵ ⋄ ↑(⊂⍤b⊢⍺) ⍺⍺¨ ⊂⍤c⊢⍵} is an impl of the dyadic case from the monadic one (with Dyalog's ↑ meaning))
as <- atRank1 enclose' ra a
bs <- atRank1 enclose' rb b
each2 f as bs >>= atRank1 first 0
atRank2' :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> Array -> m Array
atRank2' f r x y = do
(_, b, c) <- parseRank r
atRank2 f (b, c) x y
⎕ts
⎕ts is a simple nilad that returns the current Unix timestamp.
ts = Nilad (Just $ scalar . Number . realToFrac <$> liftIO getPOSIXTime) Nothing (G.quad : "ts")
Compiling to WASM + JS FFI
The tinyapl.cabal file has a new executable entry, tinyapl-js, with some config options:
executable tinyapl-js
import: warnings
main-is: Main.hs
build-depends: base ^>=4.20.0.0
, ghc-experimental ^>=0.1.0.0
, tinyapl
hs-source-dirs: js/src
default-language: Haskell2010
ghc-options: -W -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start"
This only compiles under wasm32-wasi, because it depends on the JavaScript FFI and GHC.Wasm.Prim.
Next, we need to run a post-link script. I wrote a bash file for convenience which does everything, including copying support files:
#!/bin/bash
set -e
if [[ $PWD == */js ]]; then
echo "build.sh must be ran in the root tinyapl directory"
exit 1
fi
rm -rf js/dist
mkdir js/dist
echo "Compiling library"
wasm32-wasi-cabal build tinyapl-js
out_path=$(find dist-newstyle -name "*-js.wasm")
echo "Compiled, found $out_path"
"$(wasm32-wasi-ghc --print-libdir)"/post-link.mjs --input "$out_path" --output js/ghc_wasm_jsffi.js
echo "Post-linked, copying files"
cp $out_path js/dist/tinyapl-js.wasm
cp js/*.js js/dist
cp js/*.html js/dist
Syntax Highlighting
One of the components of the web interface which I'll describe later is syntax highlighting, so here's a module implementing that.
First, the color categories:
data Color
= COther
| CSyntax
| CNumber
| CString
| CStringEscape
| CArrayName
| CPrimArray
| CFunctionName
| CPrimFunction
| CAdverbName
| CPrimAdverb
| CConjunctionName
| CPrimConjunction
| CComment
deriving (Enum, Show)
And the parser state:
data HState = HState
{ hColors :: [Color]
, hStr :: String }
type HSt = State HState
The actual highlighter:
highlight :: String -> [Color]
highlight str = reverse $ hColors $ execState hl (HState [] str) where
atEnd :: HSt Bool
atEnd = do
str <- gets hStr
pure $ null str
andNotAtEnd :: HSt Bool -> HSt Bool
andNotAtEnd p = do
e <- atEnd
if e then pure False else p
peek :: HSt Char
peek = do
str <- gets hStr
pure $ case str of (s:_) -> s; [] -> chr 0
advance :: HSt Char
advance = do
st <- get
let ss = hStr st
case ss of
[] -> pure $ chr 0
(s:ss') -> do
put $ st{ hStr = ss' }
pure s
push :: Color -> HSt ()
push c = do
st@HState{ hColors = cs } <- get
put $ st{ hColors = c : cs }
pushMany :: [Color] -> HSt ()
pushMany = mapM_ push
Highlighting strings is just consuming all characters until the closing quote, checking for escapes:
string :: HSt ()
string = do
start <- advance
let isString = start == G.stringDelimiter
push CString
whileM_ (andNotAtEnd $ (/= start) <$> peek) $ do
c <- peek
if isString && c == G.stringEscape then do
advance
push CStringEscape
advance
push CStringEscape
else return ()
advance
push CString
advance
push CString
Numbers are pretty much the same thing, consuming while a number character is found:
numberChars = ['0'..'9'] ++ [G.decimal, G.negative, G.exponent, G.imaginary, G.infinity]
number :: HSt ()
number = whileM_ (andNotAtEnd $ (`elem` numberChars) <$> peek) $ do
advance
push CNumber
Comments are just like strings, except no escapes:
comment :: HSt ()
comment = do
advance
push CComment
whileM_ (andNotAtEnd $ (/= (snd G.inlineComment)) <$> peek) $ do
advance
push CComment
advance
push CComment
Identifiers consume while identifier characters are found and then decide what type of identifier it is based on the casing and underscores:
identifier :: HSt ()
identifier = do
is <- whileM (andNotAtEnd $ (`elem` identifierChars) <$> peek) advance
if head is `elem` ['a'..'z'] ++ [G.alpha, G.omega, G.quad, G.quadQuote, G.delta] then pushMany $ const CArrayName <$> is
else if head is `elem` ['A'..'Z'] ++ [G.alphaBar, G.omegaBar, G.deltaBar, G.del] then pushMany $ const CFunctionName <$> is
else if head is == '_' && last is == '_' then pushMany $ const CConjunctionName <$> is
else if head is == '_' then pushMany $ const CAdverbName <$> is
else pushMany $ const COther <$> is
And then to tie it all together:
hl :: HSt ()
hl = whileM_ (not <$> atEnd) $ do
p <- peek
if p `elem` numberChars then number
else if p `elem` [G.stringDelimiter, G.charDelimiter] then string
else if p `elem` identifierChars then identifier
else if p == fst G.inlineComment then comment
else if p `elem` G.syntax then advance >> push CSyntax
else if p `elem` G.arrays then advance >> push CPrimArray
else if p `elem` G.functions then advance >> push CPrimFunction
else if p `elem` G.adverbs then advance >> push CPrimAdverb
else if p `elem` G.conjunctions then advance >> push CPrimConjunction
else advance >> push COther
Abstracting I/O
When the web frontend will want to run code, output with quads would currently be redirected to the JS console, and input would presumably just fail. To fix this, the Scope in the St monad has been replaced by a wider Context:
data Context = Context
{ contextScope :: Scope
, contextQuads :: Quads
, contextIn :: St String
, contextOut :: String -> St ()
, contextErr :: String -> St () }
type St = StateT Context (ExceptT Error IO)
All code has been changed to reflect this change, including not using standard Haskell IO but calling these functions instead.
The tinyapl-js Library
We're now ready to export our functions to the JavaScript world!
The way code is ran from the JS side, because we can't pass around classes, is by storing a list of contexts on the Haskell side and referring to them by index when running code from JavaScript.
{-# NOINLINE contexts #-}
contexts :: IORef [Context]
contexts = unsafePerformIO $ newIORef []
foreign import javascript safe "return await $1();" callInput :: JSVal -> IO JSString
foreign import javascript safe "await $1($2);" callOutput :: JSVal -> JSString -> IO ()
foreign export javascript "tinyapl_newContext" newContext :: JSVal -> JSVal -> JSVal -> IO Int
newContext :: JSVal -> JSVal -> JSVal -> IO Int
newContext input output error = do
l <- length <$> readIORef contexts
modifyIORef contexts (++ [Context
{ contextScope = Scope [] [] [] [] Nothing
, contextQuads = core
, contextIn = liftToSt $ fromJSString <$> callInput input
, contextOut = \str -> liftToSt $ callOutput output $ toJSString str
, contextErr = \str -> liftToSt $ callOutput error $ toJSString str }])
return l
Next, the actual function that runs the code:
runCode :: Int -> String -> IO (String, Bool)
runCode contextId code = do
context <- (!! contextId) <$> readIORef contexts
let file = "<tinyapl js>"
result <- runResult $ run file code context
case result of
Left err -> return (show err, False)
Right (res, context') -> do
modifyIORef contexts (setAt contextId context')
return (show res, True)
foreign import javascript unsafe "return [$1, $2];" jsResultPair :: JSString -> Bool -> JSVal
foreign export javascript "tinyapl_runCode" runCodeJS :: Int -> JSString -> IO JSVal
runCodeJS :: Int -> JSString -> IO JSVal
runCodeJS contextId code = do
(r, s) <- runCode contextId $ fromJSString code
return $ jsResultPair (toJSString r) s
The frontend also needs a list of glyphs to create the language bar:
foreign export javascript "tinyapl_glyphsSyntax" glyphsSyntaxJS :: JSVal
foreign export javascript "tinyapl_glyphsIdentifiers" glyphsIdentifiersJS :: JSVal
foreign export javascript "tinyapl_glyphsArrays" glyphsArraysJS :: JSVal
foreign export javascript "tinyapl_glyphsFunctions" glyphsFunctionsJS :: JSVal
foreign export javascript "tinyapl_glyphsAdverbs" glyphsAdverbsJS :: JSVal
foreign export javascript "tinyapl_glyphsConjunctions" glyphsConjunctionsJS :: JSVal
glyphsSyntaxJS = toJSArray $ toJSChar <$> syntax
glyphsIdentifiersJS = toJSArray $ toJSChar <$> identifiers
glyphsArraysJS = toJSArray $ toJSChar <$> arrays
glyphsFunctionsJS = toJSArray $ toJSChar <$> functions
glyphsAdverbsJS = toJSArray $ toJSChar <$> adverbs
glyphsConjunctionsJS = toJSArray $ toJSChar <$> conjunctions
Finally, highlighting:
foreign export javascript "tinyapl_highlight" jsHighlight :: JSString -> JSVal
jsHighlight :: JSString -> JSVal
jsHighlight = toJSArray . map (intToVal . fromEnum). highlight . fromJSString
foreign export javascript "tinyapl_splitString" splitString :: JSString -> JSVal
splitString :: JSString -> JSVal
splitString = toJSArray . map toJSChar . fromJSString
foreign export javascript "tinyapl_hlOther" hlOther :: Int
foreign export javascript "tinyapl_hlSyntax" hlSyntax :: Int
foreign export javascript "tinyapl_hlNumber" hlNumber :: Int
foreign export javascript "tinyapl_hlString" hlString :: Int
foreign export javascript "tinyapl_hlStringEscape" hlStringEscape :: Int
foreign export javascript "tinyapl_hlArrayName" hlArrayName :: Int
foreign export javascript "tinyapl_hlPrimArray" hlPrimArray :: Int
foreign export javascript "tinyapl_hlFunctionName" hlFunctionName :: Int
foreign export javascript "tinyapl_hlPrimFunction" hlPrimFunction :: Int
foreign export javascript "tinyapl_hlAdverbName" hlAdverbName :: Int
foreign export javascript "tinyapl_hlPrimAdverb" hlPrimAdverb :: Int
foreign export javascript "tinyapl_hlConjunctionName" hlConjunctionName :: Int
foreign export javascript "tinyapl_hlPrimConjunction" hlPrimConjunction :: Int
foreign export javascript "tinyapl_hlComment" hlComment :: Int
hlOther = fromEnum COther
hlSyntax = fromEnum CSyntax
hlNumber = fromEnum CNumber
hlString = fromEnum CString
hlStringEscape = fromEnum CStringEscape
hlArrayName = fromEnum CArrayName
hlPrimArray = fromEnum CPrimArray
hlFunctionName = fromEnum CFunctionName
hlPrimFunction = fromEnum CPrimFunction
hlAdverbName = fromEnum CAdverbName
hlPrimAdverb = fromEnum CPrimAdverb
hlConjunctionName = fromEnum CConjunctionName
hlPrimConjunction = fromEnum CPrimConjunction
hlComment = fromEnum CComment
Now, we just need to write the other side of the code, which loads the compiled WASM and FFI script:
import { WASI, OpenFile, File, ConsoleStdout } from 'https://esm.run/@bjorn3/browser_wasi_shim@0.3.0';
import ghc_wasm_jsffi from './ghc_wasm_jsffi.js';
const args = [];
const env = [];
const files = [
new OpenFile(new File([])), // stdin
ConsoleStdout.lineBuffered(msg => console.log(`[WASI] ${msg}`)), // stdout
ConsoleStdout.lineBuffered(msg => console.warn(`[WASI] ${msg}`)), // stderr
];
const options = {};
const wasi = new WASI(args, env, files, options);
const instanceExports = {};
const { instance } = await WebAssembly.instantiateStreaming(fetch("./tinyapl-js.wasm"), {
wasi_snapshot_preview1: wasi.wasiImport,
ghc_wasm_jsffi: ghc_wasm_jsffi(instanceExports),
});
Object.assign(instanceExports, instance.exports);
wasi.initialize(instance);
The rest of the tinyapl.js file just reexports all the functions from the Haskell code, here's an example:
/**
* Run code in a context
* @param {number} context Context ID
* @param {string} code
* @returns {Promise<[string, boolean]>} A pair containing the result of the code or the error and whether running succeeded
*/
export async function runCode(context, code) {
const [result, success] = await instance.exports.tinyapl_runCode(context, code);
return [result, Boolean(success)];
}
The Web Interface
The actual code for the web interface is probably out of scope for this post and maybe even uninteresting. As of now, the supported features are: a language bar, input using a prefix key, syntax highlighting, running from URL search params. It's also been tied in to the docs system by moving all doc pages to a /docs subdirectory and adding /run which lists all available versions of the interpreter. You can visit https://tinyapl.rubenverg.com/run/latest for the latest stable version and https://beta.tinyapl.rubenverg.com/run/latest for a preview version. Here's a screenshot of the interface showing off some features:
If you want to run exactly the version from this post, it's available at https://tinyapl.rubenverg.com/run/0.5.0.