As usual, code is available in a GitHub repository.
Refactoring
To make it easier for functions to use implementations of other functions, I extracted all the functions from the pureFunction arguments and generalized them to take any MonadError Error m instead of plain Result/ResultIO/St. Most of the functions have a version which operates on the most natural Haskell datatype, and a version labeled with a ' which takes arrays and does error checking.
Scalar functions generally look like this:
conjugate :: MonadError Error m => ScalarValue -> m ScalarValue
conjugate (Number y) = pure $ Number $ Cx.conjugate y
conjugate _ = throwError expectedNumber
conjugate' :: MonadError Error m => Array -> m Array
conjugate' = scalarMonad conjugate
And here's a non-scalar function:
reshape :: MonadError Error m => [Integer] -> Array -> m Array
reshape shape arr@(Array _ xs) = do
let negative = count (< 0) shape
if negative == 0 then case arrayReshaped (fromInteger . toInteger <$> shape) xs of
Nothing -> throwError $ DomainError "Cannot reshape an empty array to a non-empty array"
Just res -> pure res
else if negative == 1 && -1 `elem` shape then do
let bound = genericLength xs
let known = product $ filter (>= 0) shape
if known == 0 then throwError $ DomainError "Shape cannot contain both 0 and -1"
else if bound `mod` known /= 0 then throwError $ DomainError "Shape is not a multiple of the bound of the array"
else reshape ((\x -> if x == -1 then bound `div` known else x) <$> shape) arr
else throwError $ DomainError "Invalid shape"
reshape' :: MonadError Error m => Array -> Array -> m Array
reshape' sh arr = do
let err = DomainError "Shape must be an integer vector"
shape <- asVector err sh >>= mapM (asNumber err >=> asInt err)
reshape shape arr
Similarly, all operators have been extracted into functions and the Function enum has been reduced to a simple record.
compose :: MonadError Error m => (b -> m c) -> (a -> m b) -> a -> m c
compose f g = g >=> f
atop :: MonadError Error m => (c -> m d) -> (a -> b -> m c) -> a -> b -> m d
atop f g x y = g x y >>= f
atop = Conjunction
{ conjRepr = [G.atop]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Just $ \_ _ -> throwError $ NYIError "Rank operator not implemented yet"
, conjOnFunctionFunction = Just $ \f g -> pure $ Function (Just $ F.compose (callMonad f) (callMonad g)) (Just $ F.atop (callMonad f) (callDyad g)) (makeConjRepr (show f) G.atop (show g)) }
Affine character arithmetic
Affine character arithmetic is the ability to apply certain arithmetic functions on the codepoints of characters:
add (Number x) (Character y) = do
x' <- asInt expectedInteger x
pure $ Character $ chr $ ord y + x'
add (Character x) (Number y) = do
y' <- asInt expectedInteger y
pure $ Character $ chr $ ord x + y'
sub (Character x) (Number y) = do
y' <- asInt expectedInteger y
pure $ Character $ chr $ ord x - y'
sub (Character x) (Character y) = pure $ Number $ fromInteger . toInteger $ ord x - ord y
Supporting quad names
First, changing the parser to accept quad names:
arrayName = try (liftA3 (\x y z -> x : y : z) (char G.quad) (oneOf arrayStart) (many $ oneOf identifierRest)) <|> try (string [G.alpha, G.alpha]) <|> try (string [G.omega, G.omega]) <|> try (string [G.alpha]) <|> try (string [G.omega]) <|> try (string [G.quad]) <|> try (string [G.quadQuote]) <|> liftA2 (:) (oneOf arrayStart) (many $ oneOf identifierRest)
functionName = try (liftA3 (\x y z -> x : y : z) (char G.quad) (oneOf functionStart) (many $ oneOf identifierRest)) <|> try (string [G.del]) <|> try (string [G.alphaBar, G.alphaBar]) <|> try (string [G.omegaBar, G.omegaBar]) <|> liftA2 (:) (oneOf functionStart) (many $ oneOf identifierRest)
adverbName = try (liftA3 (\x y z -> x : y : z) (char G.quad) (char G.underscore) (many $ oneOf identifierRest)) <|> try (string [G.underscore, G.del]) <|> liftA2 (:) (char G.underscore) (many1 $ oneOf identifierRest)
conjunctionName = try ((\x y z w -> x : y : z ++ [w]) <$> char G.quad <*> char G.underscore <*> many (oneOf identifierRest) <*> char G.underscore) <|> try (string [G.underscore, G.del, G.underscore]) <|> liftA3 (\a b c -> a : b ++ [c]) (char G.underscore) (many1 $ oneOf identifierRest) (char G.underscore)
Quad array names are special in that accessing them may yield a non-constant value and setting them can trigger side effects; also some quad names can only be get and others can only be set:
data Nilad = Nilad
{ niladGet :: Maybe (St Array)
, niladSet :: Maybe (Array -> St ())
, niladRepr :: String }
instance Show Nilad where
show (Nilad { niladRepr = r }) = r
data Quads = Quads
{ quadArrays :: [(String, Nilad)]
, quadFunctions :: [(String, Function)]
, quadAdverbs :: [(String, Adverb)]
, quadConjunctions :: [(String, Conjunction)] }
deriving (Show)
Quad names are not intrinsic to the language as primitives are, instead different contexts can use different quad names. They are stored as a member of the Scope:
data Scope = Scope
{ scopeArrays :: [(String, Array)]
, scopeFunctions :: [(String, Function)]
, scopeAdverbs :: [(String, Adverb)]
, scopeConjunctions :: [(String, Conjunction)]
, scopeParent :: Maybe Scope
, scopeQuads :: Quads }
Next, the interpreter has to recognize quad names and call them instead of looking up a name in the normal scope table:
evalLeaf (TokenArrayName name _)
-- ...
| head name == G.quad = do
quads <- gets scopeQuads
let nilad = lookup name $ quadArrays quads
case nilad of
Just x -> case niladGet x of
Just g -> VArray <$> g
Nothing -> throwError $ SyntaxError $ "Quad name " ++ name ++ " cannot be accessed"
Nothing -> throwError $ SyntaxError $ "Unknown quad name " ++ name
evalLeaf (TokenFunctionName name _)
| head name == G.quad = do
quads <- gets scopeQuads
let fn = lookup name $ quadFunctions quads
case fn of
Just x -> return $ VFunction x
Nothing -> throwError $ SyntaxError $ "Unknown quad name " ++ name
evalLeaf (TokenAdverbName name _)
| head name == G.quad = do
quads <- gets scopeQuads
let adv = lookup name $ quadAdverbs quads
case adv of
Just x -> return $ VAdverb x
Nothing -> throwError $ SyntaxError $ "Unknown quad name " ++ name
evalLeaf (TokenConjunctionName name _)
| head name == G.quad = do
quads <- gets scopeQuads
let conj = lookup name $ quadConjunctions quads
case conj of
Just x -> return $ VConjunction x
Nothing -> throwError $ SyntaxError $ "Unknown quad name " ++ name
Similarly for array assignment:
| head name == G.quad = do
arr <- unwrapArray (DomainError "Cannot set quad name to non-array") val
quads <- gets scopeQuads
let nilad = lookup name $ quadArrays quads
case nilad of
Just x -> case niladSet x of
Just s -> do
s arr
return val
Nothing -> throwError $ SyntaxError $ "Quad name " ++ name ++ " cannot be set"
Nothing -> throwError $ SyntaxError $ "Unknown quad name " ++ name
Implementing quad names
Now that the structure is in place, quad names can be implemented. For now, I did the easy ones:
module TinyAPL.CoreQuads where
-- ...
io = Nilad (Just $ pure $ scalar $ Number 1) Nothing (G.quad : "io")
ct = Nilad (Just $ pure $ scalar $ Number $ comparisonTolerance :+ 0) Nothing (G.quad : "ct")
u = Nilad (Just $ pure $ vector $ Character <$> ['A'..'Z']) Nothing (G.quad : "u")
l = Nilad (Just $ pure $ vector $ Character <$> ['a'..'z']) Nothing (G.quad : "l")
d = Nilad (Just $ pure $ vector $ Character <$> ['0'..'9']) Nothing (G.quad : "d")
exists = Function (Just $ \x -> do
let var = show x
scope <- get
case scopeLookup var scope of
Just _ -> return $ scalar $ Number 1
Nothing -> return $ scalar $ Number 0
) Nothing (G.quad : "Exists")
core = Quads
((\x -> (niladRepr x, x)) <$>
[ io, ct, u, l, d ])
((\x -> (dfnRepr x, x)) <$>
[ exists ])
((\x -> (adverbRepr x, x)) <$>
[])
((\x -> (conjRepr x, x)) <$>
[])
⎕Repr: representing arrays
The ⎕Repr quad name serializes an array into a format that can be read by ⍎ (which I didn't implement yet).
repr = Function (Just $ \x -> return $ vector $ Character <$> arrayRepr x) Nothing (G.quad : "Repr")
charRepr :: Char -> (String, Bool)
charRepr c = case lookup c (swap <$> G.escapes) of
Just e -> ([G.stringEscape, e], True)
Nothing -> ([c], False)
scalarRepr :: ScalarValue -> String
scalarRepr (Number x) = showComplex x
scalarRepr (Character x) = case charRepr x of
(e, True) -> [G.first, G.stringDelimiter] ++ e ++ [G.stringDelimiter]
(c, False) -> [G.charDelimiter] ++ c ++ [G.charDelimiter]
scalarRepr (Box xs) = G.enclose : arrayRepr xs
stringRepr :: [Char] -> String
stringRepr str = [G.stringDelimiter] ++ concatMap (fst . charRepr) str ++ [G.stringDelimiter]
arrayRepr :: Array -> String
arrayRepr (Array [] [s]) = scalarRepr s
arrayRepr (Array [_] xs)
| not (null xs) && all (\case (Character _) -> True; _ -> False) xs = stringRepr $ (\case (Character c) -> c; _ -> undefined) <$> xs
| otherwise = [fst G.vector] ++ intercalate [' ', G.separator, ' '] (arrayRepr . fromScalar <$> xs) ++ [snd G.vector]
arrayRepr arr = [fst G.highRank] ++ intercalate [' ', G.separator, ' '] (arrayRepr <$> majorCells arr) ++ [snd G.highRank]
Decoupling array functions from Result
Another big refactoring: array functions can now accept any MonadError Error m.
asScalar :: MonadError Error m => Error -> Array -> m ScalarValue
asScalar _ (Array _ [x]) = pure x
asScalar e _ = throwError e
-- et cetera
[!] Roll and Seed
[!] All the code in this section has temporarily been removed as the random package does not compile on the WASM backend.
Roll ? uses random as a dependency to generate random numbers; therefore it requires a MonadIO as the running context and not just a MonadError Error.
roll :: (MonadError Error m, MonadIO m) => Natural -> m Double
roll y =
if y == 0 then randomRIO (0, 1)
else fromInteger <$> randomRIO (1, toInteger y)
roll' :: (MonadError Error m, MonadIO m) => Array -> m Array
roll' = scalarMonad $ \y -> do
n <- asNumber expectedNatural y >>= asNat expectedNatural
Number . (:+ 0) <$> roll n
⎕seed is a set-only quad array that is used to seed the random generator:
seed = Nilad Nothing (Just $ \x -> do
let e = DomainError "Seed must be a scalar integer"
seed <- liftEither (asScalar e x) >>= liftEither . asNumber e >>= liftEither . asInt e
setStdGen $ mkStdGen seed) (G.quad : "seed")
Removing the Set * functions
Set Phase, Set Real Part and Set Imaginary part have all been removed. I think I'm still in a phase where I can remove things without warning (though I did put a deprecation notice for a few days in the docs), it's not like anybody uses TinyAPL anyways.
Changing Reduce and Scan
Scans have been removed in favor of new On Prefixes ↟ and On Suffixes ↡ adverbs, which generalize scans to non-reduction functions. Reduces have had their name and glyph changed (Reduce Down → Reduce ⍆, Reduce Up → Reduce Back ⍅).
onPrefixes :: MonadError Error m => ([a] -> m b) -> [a] -> m [b]
onPrefixes f = mapM f . prefixes
onPrefixes' :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onPrefixes' f arr = fromMajorCells <$> onPrefixes (f . fromMajorCells) (majorCells arr)
onSuffixes :: MonadError Error m => ([a] -> m b) -> [a] -> m [b]
onSuffixes f = mapM f . suffixes
onSuffixes' :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onSuffixes' f arr = fromMajorCells <$> onSuffixes (f . fromMajorCells) (majorCells arr)
Key
Key ⌸ is an adverb that calls a function on each unique value of the left argument and the corresponding values of the right argument.
group :: Eq k => [k] -> [a] -> [(k, [a])]
group [] [] = []
group (k:ks) (a:as) = let gs = group ks as in case lookup k gs of
Just g -> (k, a:g) : delete gs k
Nothing -> (k, [a]) : gs
group _ _ = error "group: mismatched array lengths"
key :: (Eq a, MonadError Error m) => (a -> [b] -> m c) -> [a] -> [b] -> m [c]
key f ks vs
| length ks == length vs = mapM (uncurry f) (group ks vs)
| otherwise = throwError $ LengthError "Incompatible shapes to Key"
key' :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
key' f karr varr = fromMajorCells <$> key (\k vs -> f k $ vector $ toScalar <$> vs) (majorCells karr) (majorCells varr)
keyMonad :: MonadError Error m => (Array -> Array -> m Array) -> Array -> m Array
keyMonad f arr = do
t <- tally' arr
is <- indexGenerator' t
key' f arr is
Indexing
Two indexing functions are available in TinyAPL: From ⊇ and (squad) Index ⌷.
Squad indexing is easier:
indexCells :: MonadError Error m => [Integer] -> [a] -> m [a]
indexCells [] _ = pure []
indexCells (i:is) xs
| i < 0 = indexCells (genericLength xs + i + 1 : is) xs
| i == 0 || i > genericLength xs = throwError $ DomainError "Index out of bounds"
| otherwise = (genericIndex xs (i - 1) :) <$> indexCells is xs
indexDeep :: MonadError Error m => [[Integer]] -> Array -> m Array
indexDeep [] arr = pure arr
indexDeep (i:is) arr = indexCells i (majorCells arr) >>= (fmap (\x -> if length x == 1 then head x else fromMajorCells x) . mapM (indexDeep is))
squad :: MonadError Error m => Array -> Array -> m Array
squad iarr carr = do
let err = DomainError "Squad left argument must be a vector of scalar integers or vectors of integers"
is <- asVector err iarr >>= mapM (asVector err >=> mapM (asNumber err >=> asInt err)) . fmap fromScalar
indexDeep is carr
From is more complex; it could be easily implemented using Rank but I don't have that yet. TODO: refactor!
indexScatter :: MonadError Error m => Array -> Array -> m Array
indexScatter iarr carr = each1 (\i -> do
let err = DomainError "From left argument must be an integer vector or array of integer vectors"
is <- asVector err i >>= mapM (asNumber err >=> asInt err)
indexDeep (singleton <$> is) carr) iarr
from :: MonadError Error m => Array -> Array -> m Array
from iarr carr
| null (arrayShape iarr) && all (\case { Number _ -> True; _ -> False }) (arrayContents iarr) = do
let err = DomainError "From left argument must be an integer vector or an array of integer vectors"
index <- asScalar err iarr >>= asNumber err >>= asInt err
head <$> indexCells [index] (majorCells carr)
| length (arrayShape iarr) == 1 && all (\case { Number _ -> True; _ -> False }) (arrayContents iarr) = do
let err = DomainError "From left argument must be an integer vector or an array of integer vectors"
indices <- asVector err iarr >>= mapM (asNumber err >=> asInt err)
fromMajorCells <$> indexCells indices (majorCells carr)
| otherwise = indexScatter iarr carr