Strap in, this is a long one. Three important things are added to TinyAPL in this post: wraps (first-class functions and modifiers), structs (think Dyalog namespaces) and a standard library. Along these many primitives have also been implemented, including fundamental ones like Catenate or Transpose.
Just like always, you can see all the code for this post in the GitHub repository
Separators and Comments
Single newlines have been changed to not be statement separators instead; if you want to separate use a diamond or a double newline. Line comments have also been added. This is made very easy with Megaparsec's Lexer:
spaceConsumer = L.space (void $ satisfy (liftA2 (&&) isSpace (/= '\n')) <|> try (char '\n' <* notFollowedBy (char '\n'))) (L.skipLineComment [G.comment]) (L.skipBlockComment [fst G.inlineComment] [snd G.inlineComment])
Additionally, empty statements are allowed and they evaluate to the empty vector.
Repeat and Until
Repeat is a conjunction that applies a function a specified amount of times:
repeat :: MonadError Error m => (a -> m a) -> Natural -> a -> m a
repeat _ 0 x = pure x
repeat f n x = f x >>= TinyAPL.Functions.repeat f (n - 1)
repeat1 :: MonadError Error m => (Array -> m Array) -> Array -> Array -> m Array
repeat1 f t y = do
let err = DomainError "Repeat right operand must be a natural scalar"
n <- asScalar err t >>= asNumber err >>= asNat err
TinyAPL.Functions.repeat f n y
repeat2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> Array -> m Array
repeat2 f t x y = do
let err = DomainError "Repeat right operand must be a natural scalar"
n <- asScalar err t >>= asNumber err >>= asNat err
TinyAPL.Functions.repeat (f x) n y
Until calls the left function until the right one returns true:
until :: MonadError Error m => (a -> m a) -> (a -> a -> m Bool) -> a -> m a
until f p x = let
go :: Monad m => (a -> m a) -> (a -> a -> m Bool) -> a -> a -> m a
go f p prev x = do
r <- f x
t <- p r prev
if t then pure r else go f p x r
in f x >>= go f p x
until1 :: MonadError Error m => (Array -> m Array) -> (Array -> Array -> m Array) -> Array -> m Array
until1 f p y = let
err = DomainError "Until right operand must return a boolean scalar"
in TinyAPL.Functions.until f (\cu pr -> p cu pr >>= asScalar err >>= asBool err) y
until2 :: MonadError Error m => (Array -> Array -> m Array) -> (Array -> Array -> m Array) -> Array -> Array -> m Array
until2 f p x y = let
err = DomainError "Until right operand must return a boolean scalar"
in TinyAPL.Functions.until (f x) (\cu pr -> p cu pr >>= asScalar err >>= asBool err) y
Catenate
The normal APL catenate function, which promotes when rank is 1-different and reshapes scalars.
catenate :: MonadError Error m => Array -> Array -> m Array
catenate a@(Array ash acs) b@(Array bsh bcs) =
if arrayRank a == arrayRank b then
if (isScalar a && isScalar b) || (tailMaybe ash == tailMaybe bsh) then pure $ fromMajorCells $ majorCells a ++ majorCells b
else throwError $ LengthError "Incompatible shapes to Catenate"
else if isScalar a then catenate (fromJust $ arrayReshaped (1 : tailPromise bsh) acs) b
else if isScalar b then catenate a (fromJust $ arrayReshaped (1 : tailPromise ash) bcs)
else if arrayRank a == arrayRank b + 1 then promote b >>= (a `catenate`)
else if arrayRank a + 1 == arrayRank b then promote a >>= (`catenate` b)
else throwError $ RankError "Incompatible ranks to Catenate"
TAO Operations
TinyAPL currently supports two TAO comparisons (i.e. comparisons that operate on arrays as a whole and not on each element): Identical (the equivalent of =) and Not Identical (the equivalent of ≠). Here are the four missing ones: Precedes ⊲ (the equivalent of <), Precedes or Identical ⊴ (the equivalent of ≤), Succeeds or Identical ⊵ (the equivalent of ≥) and Succeeds ⊳ (the equivalent of >).
precedes :: MonadError Error m => Array -> Array -> m Bool
precedes x y = pure $ x < y
precedes' :: MonadError Error m => Array -> Array -> m Array
precedes' x y = scalar . boolToScalar <$> precedes x y
precedesOrIdentical :: MonadError Error m => Array -> Array -> m Bool
precedesOrIdentical x y = pure $ x <= y
precedesOrIdentical' :: MonadError Error m => Array -> Array -> m Array
precedesOrIdentical' x y = scalar . boolToScalar <$> precedesOrIdentical x y
succeedsOrIdentical :: MonadError Error m => Array -> Array -> m Bool
succeedsOrIdentical x y = pure $ x >= y
succeedsOrIdentical' :: MonadError Error m => Array -> Array -> m Array
succeedsOrIdentical' x y = scalar . boolToScalar <$> succeedsOrIdentical x y
succeeds :: MonadError Error m => Array -> Array -> m Bool
succeeds x y = pure $ x > y
succeeds' :: MonadError Error m => Array -> Array -> m Array
succeeds' x y = scalar . boolToScalar <$> succeeds x y
Two other functions that can be TAO-ified are Minimum and Maximum, which respectively become Minimal ⇂ and Maximal ↾.
minimal :: MonadError Error m => Array -> Array -> m Array
minimal x y = pure $ Prelude.min x y
maximal :: MonadError Error m => Array -> Array -> m Array
maximal x y = pure $ Prelude.max x y
Grading and Sorting
Six functions: Grade Up ⍋, Grade Down ⍒, Sort By Up ⍋, Sort By Down ⍒, Sort Up ⊴, Sort Down ⊵.
gradeUp :: MonadError Error m => Ord a => [a] -> m [Natural]
gradeUp xs = pure $ map fst $ sortOn snd $ zip [1..genericLength xs] xs
gradeUp' :: MonadError Error m => Array -> m Array
gradeUp' arr = vector . fmap (Number . fromInteger . toInteger) <$> gradeUp (majorCells arr)
gradeDown :: MonadError Error m => Ord a => [a] -> m [Natural]
gradeDown xs = pure $ map fst $ sortOn snd $ zip [1..genericLength xs] (Down <$> xs)
gradeDown' :: MonadError Error m => Array -> m Array
gradeDown' arr = vector . fmap (Number . fromInteger . toInteger) <$> gradeDown (majorCells arr)
sortByUp :: MonadError Error m => Ord b => [a] -> [b] -> m [a]
sortByUp as bs = pure $ map fst $ sortOn snd $ zip as bs
sortByUp' :: MonadError Error m => Array -> Array -> m Array
sortByUp' as bs = fromMajorCells <$> sortByUp (majorCells as) (majorCells bs)
sortByDown :: MonadError Error m => Ord b => [a] -> [b] -> m [a]
sortByDown as bs = pure $ map fst $ sortOn snd $ zip as $ Down <$> bs
sortByDown' :: MonadError Error m => Array -> Array -> m Array
sortByDown' as bs = fromMajorCells <$> sortByDown (majorCells as) (majorCells bs)
sortUp :: MonadError Error m => Ord a =>[a] -> m [a]
sortUp = pure . sort
sortUp' :: MonadError Error m => Array -> m Array
sortUp' = fmap fromMajorCells . sortUp . majorCells
sortDown :: MonadError Error m => Ord a => [a] -> m [a]
sortDown = pure . fmap getDown . sort . fmap Down
sortDown' :: MonadError Error m => Array -> m Array
sortDown' = fmap fromMajorCells . sortDown . majorCells
Transpose
My implementation of (dyad) Transpose is taken (or stolen) from Tests, Derivations, Proofs by Hui.
reorderAxes' :: MonadError Error m => Array -> Array -> m Array
reorderAxes' x y = do
shy <- shape' y
sx <- sortUp' x
is <- sortByUp' shy x
is' <- key' ((reduce' min') `atop` (pure .: flip const)) sx is
iota <- indexGenerator' is'
indices <- eachRight from x iota
from indices y
reorderAxes :: MonadError Error m => [Natural] -> Array -> m Array
reorderAxes is arr = reorderAxes' (vector $ Number . fromInteger . toInteger <$> is) arr
transpose :: MonadError Error m => Array -> m Array
transpose arr = do
r <- rank' arr >>= indexGenerator' >>= reverse'
reorderAxes' r arr
Valences
Ah, an easy one! Valences ⁖ calls the left function if called monadically and the right function if called dyadically. In fact, it's so easy it doesn't even have a definition in Functions, so here's the Primitives definition:
valences = Conjunction
{ conjRepr = [G.valences]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Nothing
, conjOnFunctionFunction = Just $ \f g -> pure $ Function (Just $ callMonad f) (Just $ callDyad g) (makeConjRepr (show f) G.valences (show g)) Nothing }
Structural Under
Under ⍢ is a conjunction which applies a structural function, then another function, and then undoes the strucutral transformation. Extra care is taken for it to work with sorts when used as a transformation function. It is implemented by calling the transformation function with pairs of "marker" numbers and actual values.
under :: MonadError Error m => (Array -> m Array) -> (Array -> m Array) -> Array -> m Array
under f g arr = do
let nums = fromJust $ arrayReshaped (arrayShape arr) $ Number . (:+ 0) <$> [1..]
pairs <- atRank2 (atop enclose' pair) (0, 0) arr nums
rs <- g pairs
nums' <- atRank1 (compose TinyAPL.Functions.last first) 0 rs
if Prelude.not $ distinct $ arrayContents rs then throwError $ DomainError "Under right operand must return each element at most once"
else do
res <- atRank1 (compose first first) 0 rs >>= f
if isScalar res then do
pure $ Array (arrayShape arr) $ zipWith (\num el -> if num `elem` (arrayContents nums') then headPromise $ arrayContents res else el) (arrayContents nums) (arrayContents arr)
else if arrayShape nums' == arrayShape res then do
let cs = zip (arrayContents nums') (arrayContents res)
pure $ Array (arrayShape arr) $ zipWith (\num el -> case find (\(num', _) -> num == num') cs of
Just (_, el') -> el'
Nothing -> el) (arrayContents nums) (arrayContents arr)
else throwError $ DomainError "Under left argument mustn't change the shape of the argument"
under2 :: MonadError Error m => (Array -> Array -> m Array) -> (Array -> m Array) -> Array -> Array -> m Array
under2 f g x = under (f x) g
underK :: MonadError Error m => Array -> (Array -> m Array) -> Array -> m Array
underK arr = under (\_ -> pure arr)
Matrix Inverse and Matrix Divide
These two functions are implemented using the matrix Haskell library.
matrixInverse :: MonadError Error m => M.Matrix (Complex Double) -> m (M.Matrix (Complex Double))
matrixInverse y = do
let hermitian = fmap Cx.conjugate . M.transpose
case M.inverse (hermitian y * y) of
Left err -> throwError $ DomainError err
Right r -> pure $ r * hermitian y
matrixInverse' :: MonadError Error m => Array -> m Array
matrixInverse' = atRank1 (\y -> do
r <- rank y
mat <- asMatrix (DomainError "") y >>= mapM (asNumber (DomainError "Matrix inverse argument must be numeric"))
inv <- fmap Number <$> matrixInverse (if r < 2 then M.transpose mat else mat)
if r < 2 then pure $ Array (arrayShape y) (M.toList inv)
else pure $ matrix inv) 2
matrixDivide :: MonadError Error m => M.Matrix (Complex Double) -> M.Matrix (Complex Double) -> m (M.Matrix (Complex Double))
matrixDivide x y = (* x) <$> matrixInverse y
matrixDivide' :: MonadError Error m => Array -> Array -> m Array
matrixDivide' = atRank2 (\x y -> do
x' <- asMatrix (DomainError "") x >>= mapM (asNumber (DomainError "Matrix divide arguments must be numeric"))
y' <- asMatrix (DomainError "") y >>= mapM (asNumber (DomainError "Matrix divide arguments must be numeric"))
matrix . fmap Number <$> matrixDivide x' y') (2, 2)
On Cells and On Scalars
These two are just helper modifiers that are equivalent to applications of Rank: On Cells ◡ applies to rank -1, On Scalars ◠ to rank 0
onCells1 :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onCells1 f = atRank1 f (-1)
onCells2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
onCells2 f = atRank2 f (-1, -1)
onScalars1 :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onScalars1 f = atRank1 f 0
onScalars2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
onScalars2 f = atRank2 f (0, 0)
Boxed and On Contents
Boxed ᑣ and On Contents ᑒ are designed to break Each into more fundamental parts: apply to scalars, disclose arguments, enclose results.
boxed1 :: MonadError Error m => (Array -> m Array) -> Array -> m Array
boxed1 = compose enclose'
boxed2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
boxed2 = atop enclose'
onContents1 :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onContents1 = (`compose` first)
onContents2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
onContents2 = (`over` first)
Table
Table ⊞ is like other APL's Outer Product except it's flat instead of nested: while Outer Product can be defined as F¨⍤0‿∞, TinyAPL's Table is F◠⍤0‿∞.
table :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
table f = atRank2 (atRank2 f (0, 0)) (0, 10000)
Inner Product
Just like Table, Inner Product ∙ is flat instead of nested:
innerProduct :: MonadError Error m => (Array -> m Array) -> (Array -> Array -> m Array) -> Array -> Array -> m Array
innerProduct f g = atRank2 (atop f (atRank2 (atRank2 g (0, 0)) (-1, -1))) (1, 10000)
Factorial and Binomial
I would like to depend on the gamma library, but sadly it depends on Template Haskell and currently TH isn't supported on the WASM backend yet. Luckily, the changes required to get it working are minor so I just embedded the source. After that, Factorial is easy:
factorial :: MonadError Error m => ScalarValue -> m ScalarValue
factorial (Number n) = case asInt (DomainError "") n of
Left _ -> pure $ Number $ Gamma.gamma $ n + 1
Right i
| i < 0 -> throwError $ DomainError "Factorial of a negative integer"
| otherwise -> pure $ Number $ Gamma.factorial i
factorial _ = throwError expectedNumber
factorial' :: MonadError Error m => Array -> m Array
factorial' = scalarMonad factorial
Binomial is a bit more complex because it has many cases:
binomial :: MonadError Error m => ScalarValue -> ScalarValue -> m ScalarValue
binomial (Number x) (Number y) = let
go :: MonadError Error m => Complex Double -> Complex Double -> m (Complex Double)
go n k = do
let ni = asInt (DomainError "") n :: Either Error Integer
let ki = asInt (DomainError "") k :: Either Error Integer
case (trace (show ni) ni, trace (show ki) ki) of
(Right n', Right k')
| n' < 0 && k' >= 0 -> (((-1) ^ k') *) <$> go (k - n - 1) k
| n' < 0 && k' <= n' -> (((-1) ^ (n' - k')) *) <$> go (-k - 1) (n - k)
| n' < 0 -> pure 0
(Right n', _) | n' < 0 -> throwError $ DomainError "If Choose left argument is a negative integer, the right argument must be an integer"
(Right n', Right k')
| k' < 0 || k' > n' -> pure 0
| otherwise -> pure $ Gamma.factorial n' / (Gamma.factorial k' * Gamma.factorial (n' - k'))
_ -> pure $ Gamma.gamma (n + 1) / (Gamma.gamma (k + 1) * Gamma.gamma (n - k + 1))
in Number <$> go y x
binomial _ _ = throwError expectedNumber
binomial' :: MonadError Error m => Array -> Array -> m Array
binomial' = scalarDyad binomial
Raise
Raise ↗ is a function that throws an error.
raise :: MonadError Error m => Int -> String -> m ()
raise = throwError .: fromErrorCode
raise' :: MonadError Error m => Array -> Array -> m Array
raise' code msg = do
let err = DomainError "Raise left argument must be an integer scalar"
code' <- asScalar err code >>= asNumber err >>= asInt err
when (code' /= 0) $ raise code' $ show msg
pure $ vector []
raise1 :: MonadError Error m => Array -> m Array
raise1 msg = do
raise 1 $ show msg
pure $ vector []
Type
⎕Type is a quad function that returns the type of the (scalars of the) argument.
type_ = Function (Just $ \(Array sh cs) -> return $ Array sh $ (\case
Number _ -> Number 0
Character _ -> Number 1
Box _ -> Number 2
Wrap _ -> Number 3
AdverbWrap _ -> Number 4
ConjunctionWrap _ -> Number 5
Struct _ -> Number 6) <$> cs) Nothing (G.quad : "Type") Nothing
Closures
Currently, dfns have a weird system of capturing the outer scope where they take immutable references to copies of values. I changed that to instead make proper closing over lexical scopes, which includes noticing outside mutation and creation of new values. To accomplish this, functions (and modifiers) can optionally store a Context; when they're called, they're ran in the stored context if it exists; both Context's scope and Scope's parent scopes are also made IORef because they can be mutated.
data Function
= Function
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionRepr :: String
, functionContext :: Maybe Context }
callMonad (Function (Just f) _ _ (Just ctx)) x = runWithContext ctx $ f x
callMonad (Function (Just f) _ _ Nothing) x = f x
callMonad f@(Function Nothing _ _ _) _ = throwError $ noMonad $ show f
callDyad (Function _ (Just g) _ (Just ctx)) a b = runWithContext ctx $ g a b
callDyad (Function _ (Just g) _ Nothing) a b = g a b
callDyad f@(Function _ Nothing _ _) _ _ = throwError $ noDyad $ show f
-- same for modifiers
data Scope = Scope
{ scopeArrays :: [(String, Array)]
, scopeFunctions :: [(String, Function)]
, scopeAdverbs :: [(String, Adverb)]
, scopeConjunctions :: [(String, Conjunction)]
, scopeParent :: Maybe (IORef Scope) }
scopeLookupArray :: String -> Scope -> St (Maybe Array)
scopeLookupArray name sc = case lookup name (scopeArrays sc) of
Just x -> pure $ Just x
Nothing -> if name `elem` specialNames then pure Nothing else case scopeParent sc of
Nothing -> pure Nothing
Just p -> (liftToSt $ IORef.readIORef p) >>= scopeLookupArray name
-- same for other lookups
(and many other minor code changes to reflect the mutability changes)
Wraps
What TinyAPL calls "wraps" are essentially first-class functions, adverbs and conjunctions, that is, they're ScalarValues that contain a function or modifier. They're created with ⊏ and unwrapped with ⊐/_⊐/_⊐_.
data ScalarValue
= Number (Complex Double)
-- ...
| Wrap Function
| AdverbWrap Adverb
| ConjunctionWrap Conjunction
data Token
= TokenNumber (Complex Double) SourcePos
-- ...
| TokenWrap Token SourcePos
| TokenUnwrap Token SourcePos
| TokenUnwrapAdverb Token SourcePos
| TokenUnwrapConjunction Token SourcePos
wrap :: Parser Token
wrap = withPos $ TokenWrap <$> (char G.wrap *> bit)
unwrap :: Parser Token
unwrap = withPos $ TokenUnwrap <$> (char G.unwrap *> bit)
unwrapAdverb :: Parser Token
unwrapAdverb = withPos $ TokenUnwrapAdverb <$> (string [G.underscore, G.unwrap] *> bit)
unwrapConjunction :: Parser Token
unwrapConjunction = withPos $ TokenUnwrapConjunction <$> (string [G.underscore, G.unwrap, G.underscore] *> bit)
data Tree
= Leaf { leafCategory :: Category, leafToken :: Token }
-- ...
| WrapBranch { wrapBranchValue :: Tree }
| UnwrapBranch { unwrapBranchCategory :: Category, unwrapBranchValue :: Tree }
tokenToTree (TokenWrap val _) = WrapBranch <$> (tokenToTree val >>= (\x -> case treeCategory x of
CatFunction -> pure x
CatAdverb -> pure x
CatConjunction -> pure x
_ -> throwError $ makeSyntaxError (tokenPos val) source $ "Invalid wrap of type " ++ show (treeCategory x) ++ ", function, adverb or conjunction required"))
tokenToTree (TokenUnwrap val _) = UnwrapBranch CatFunction <$> (tokenToTree val >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos val) source $ "Invalid unwrap of type " ++ show c ++ ", array required"))
tokenToTree (TokenUnwrapAdverb val _) = UnwrapBranch CatAdverb <$> (tokenToTree val >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos val) source $ "Invalid unwrap adverb of type " ++ show c ++ ", array required"))
tokenToTree (TokenUnwrapConjunction val _) = UnwrapBranch CatConjunction <$> (tokenToTree val >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos val) source $ "Invalid unwrap conjunction of type " ++ show c ++ ", array required"))
eval (WrapBranch fn) = eval fn >>= (\case
VFunction fn -> pure $ VArray $ scalar $ Wrap fn
VAdverb adv -> pure $ VArray $ scalar $ AdverbWrap adv
VConjunction conj -> pure $ VArray $ scalar $ ConjunctionWrap conj
_ -> throwError $ DomainError "Wrap notation: function or modifier required")
eval (UnwrapBranch cat fn) = eval fn >>= evalUnwrap cat
asWraps :: MonadError Error m => Error -> Array -> m Function
asWraps err arr = do
if null $ arrayShape arr then asWrap err (headPromise $ arrayContents arr)
else pure $ Function
{ functionMonad = Just $ \x -> F.onScalars1 (\w -> asScalar err w >>= asWrap err >>= (\f -> callMonad f x)) arr
, functionDyad = Just $ \x y -> F.onScalars1 (\w -> asScalar err w >>= asWrap err >>= (\f -> callDyad f x y)) arr
, functionRepr = [fst G.parens, G.unwrap] ++ show arr ++ [snd G.parens]
, functionContext = Nothing }
evalUnwrap :: Category -> Value -> St Value
evalUnwrap CatFunction v = do
let err = DomainError "Unwrap notation: array of wraps required"
VFunction <$> (unwrapArray err v >>= asWraps err)
evalUnwrap CatAdverb v = do
let err = DomainError "Unwrap adverb notation: scalar array wrap required"
arr <- unwrapArray err v
if null $ arrayShape arr then VAdverb <$> asAdverbWrap err (headPromise $ arrayContents arr)
else throwError err
evalUnwrap CatConjunction v = do
let err = DomainError "Unwrap conjunction notation: scalar array wrap required"
arr <- unwrapArray err v
if null $ arrayShape arr then VConjunction <$> asConjunctionWrap err (headPromise $ arrayContents arr)
else throwError err
evalUnwrap _ _ = throwError unreachable
Structs
Structs are similar to Dyalog namespaces, in that they're mutable containers of variables. They're created using ⦃ and ⦄ and are scalars. All statements inside the brackets are ran in a child scope and the assigned values are collected to be available for struct access, which is done using →.
data ScalarValue
= Number (Complex Double)
-- ...
| Struct Context
data Token
= TokenNumber (Complex Double) SourcePos
-- ...
| TokenQualifiedArrayName Token (NonEmpty String) SourcePos
| TokenQualifiedFunctionName Token (NonEmpty String) SourcePos
| TokenQualifiedAdverbName Token (NonEmpty String) SourcePos
| TokenQualifiedConjunctionName Token (NonEmpty String) SourcePos
-- ...
| TokenQualifiedArrayAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedFunctionAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedAdverbAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedConjunctionAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
-- ...
| TokenStruct [NonEmpty Token] SourcePos
struct :: Parser Token
struct = withPos $ TokenStruct <$> (string [fst G.struct] *> sepBy bits separator <* string [snd G.struct])
maybeQualified ::[(Token -> NonEmpty String -> SourcePos -> Token, Token -> NonEmpty String -> AssignType -> NonEmpty Token -> SourcePos -> Token, Parser String)] -> Parser Token
maybeQualified xs = do
pos <- getSourcePos
first <- bit'
option first $ do
lexeme $ char G.access
(middle, (name, assign, last)) <- commitOn' (,) (many $ lexeme arrayName `commitOn` char G.access) (choice $ (\(n, a, p) -> (n, a, ) <$> p) <$> xs)
option (name first (snocNE middle last) pos) $ do
char G.assign
w <- bits
pure $ assign first (snocNE middle last) as w pos
array, function, adverb and conjunction have been split into array' et al which are the parts that can appear as the left side of a qualified access; bit' collects those; and array'' et al which collects the parts that cannot.
bit' :: Parser Token
bit' = lexeme $ bracketed <|> conjunction' <|> adverb' <|> function' <|> array'
bit :: Parser Token
bit = lexeme $ conjunction'' <|> adverb'' <|> function'' <|> array'' <|>
maybeQualified
[ (TokenQualifiedConjunctionName, TokenQualifiedConjunctionAssign, try conjunctionName)
, (TokenQualifiedAdverbName, TokenQualifiedAdverbAssign, adverbName)
, (TokenQualifiedFunctionName, TokenQualifiedFunctionAssign, functionName)
, (TokenQualifiedArrayName, TokenQualifiedArrayAssign, arrayName) ]
<|> conjunction' <|> adverb' <|> function' <|> array'
data Token
= TokenNumber (Complex Double) SourcePos
-- ...
| TokenQualifiedArrayName Token (NonEmpty String) SourcePos
| TokenQualifiedFunctionName Token (NonEmpty String) SourcePos
| TokenQualifiedAdverbName Token (NonEmpty String) SourcePos
| TokenQualifiedConjunctionName Token (NonEmpty String) SourcePos
-- ...
| TokenQualifiedArrayAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedFunctionAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedAdverbAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
| TokenQualifiedConjunctionAssign Token (NonEmpty String) (NonEmpty Token) SourcePos
-- ...
| TokenStruct [NonEmpty Token] SourcePos
tokenToTree (TokenQualifiedArrayName h ns _) = qualified CatArray h ns
tokenToTree (TokenQualifiedFunctionName h ns _) = qualified CatFunction h ns
tokenToTree (TokenQualifiedAdverbName h ns _) = qualified CatAdverb h ns
tokenToTree (TokenQualifiedConjunctionName h ns _) = qualified CatConjunction h ns
tokenToTree (TokenQualifiedArrayAssign h ns ts _) = qualifiedAssignment CatArray h ns ts
tokenToTree (TokenQualifiedFunctionAssign h ns ts _) = qualifiedAssignment CatFunction h ns ts
tokenToTree (TokenQualifiedAdverbAssign h ns ts _) = qualifiedAssignment CatAdverb h ns ts
tokenToTree (TokenQualifiedConjunctionAssign h ns ts _) = qualifiedAssignment CatConjunction h ns ts
tokenToTree (TokenStruct es pos) = struct es pos
qualified :: Category -> Token -> NonEmpty String -> Result Tree
qualified cat h ns = QualifiedBranch cat <$> (tokenToTree h >>=
requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos h) source $ "Invalid qualified access to value of type " ++ show c)) <*> pure ns
qualifiedAssignment :: Category -> Token -> NonEmpty String -> NonEmpty Token -> Result Tree
qualifiedAssignment cat h ns ts = liftA2 (\h' as -> QualifiedAssignBranch cat h' ns as) (tokenToTree h >>=
requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos h) source $ "Invalid qualified access to value of type " ++ show c)) (categorizeAndBind ts >>=
requireOfCategory cat (\c -> makeSyntaxError (tokenPos $ NE.head ts) source $ "Invalid assignment of " ++ show c ++ " to " ++ show cat ++ " name"))
struct :: [NonEmpty Token] -> SourcePos -> Result Tree
struct es _ = StructBranch <$> mapM (\x -> categorizeAndBind x) es
eval (QualifiedBranch _ h ns) = eval h >>= flip evalQualified ns
eval (StructBranch es) = evalStruct es
evalQualified :: Value -> NonEmpty String -> St Value
evalQualified head ns = do
let err = DomainError "Qualified name head should be a scalar struct"
let (q, l) = unsnocNE ns
headCtx <- unwrapArray err head >>= asScalar err >>= asStruct err
ctx <- resolve headCtx q
scope <- readRef $ contextScope ctx
lift $ except $ maybeToEither (SyntaxError $ "Qualified variable " ++ l ++ " does not exist") $ scopeShallowLookup False l scope
evalQualifiedAssign :: Value -> NonEmpty String -> AssignType -> Value -> St Value
evalQualifiedAssign head ns c val = do
let err = DomainError "Qualified name head should be a scalar struct"
let (q, l) = unsnocNE ns
headCtx <- unwrapArray err head >>= asScalar err >>= asStruct err
ctx <- resolve headCtx q
runWithContext ctx $ evalAssign True l c val
evalStruct :: [Tree] -> St Value
evalStruct statements = do
ctx <- get
newScope <- createRef $ Scope [] [] [] [] (Just $ contextScope ctx)
let newContext = ctx{ contextScope = newScope }
mapM_ (runWithContext newContext . eval) statements
pure $ VArray $ scalar $ Struct newContext
Assignment Types
TinyAPL has four assignment types: normal ←, modify ↩ (goes through parent scopes to find the place where the name was defined), constant ⇇ (cannot be reassigned) and private ↚ (in scopes, cannot be accessed from outside the scope).
The code for this is quite messy. It involves changing Scope entries to contain a VariableType (Normal, Constant or Private) and doing different lookups when resolving a qualified (non-private) name and an unqualified (potentially private) name; all assignment tokens and branches get a AssignType (Normal, Modify, Constant or Private). I don't think the code for this is particularly interesting, though, so I decided not to include it in this post.
Generalized Ties
In this section we add support for ties of arbitrary values instead of just number literals. First, TokenNumber is rolled back to store just one number.
data Token
= TokenNumber (Complex Double) SourcePos
-- ...
| TokenTie (NonEmpty Token) SourcePos
maybeQualifiedTie :: (NonEmpty Token -> SourcePos -> Token) -> [(Token -> NonEmpty String -> SourcePos -> Token, Token -> NonEmpty String -> AssignType -> NonEmpty Token -> SourcePos -> Token, Parser String)] -> Parser Token
maybeQualifiedTie tie xs = do
pos <- getSourcePos
first <- bit'
choice [do
lexeme $ char G.access
(middle, (name, assign, last)) <- commitOn' (,) (many $ lexeme arrayName `commitOn` char G.access) (choice $ (\(n, a, p) -> (n, a, ) <$> p) <$> xs)
option (name first (snocNE middle last) pos) $ do
as <- assignArrow
w <- bits
pure $ assign first (snocNE middle last) as w pos, do
lexeme $ char G.tie
rest <- sepBy1 bit' (lexeme $ char G.tie)
pure $ tie (first :| rest) pos, pure first]
bit :: Parser Token
bit = lexeme $ conjunction'' <|> adverb'' <|> function'' <|> array'' <|>
maybeQualifiedTie
TokenTie
[ (TokenQualifiedConjunctionName, TokenQualifiedConjunctionAssign, try conjunctionName)
, (TokenQualifiedAdverbName, TokenQualifiedAdverbAssign, adverbName)
, (TokenQualifiedFunctionName, TokenQualifiedFunctionAssign, functionName)
, (TokenQualifiedArrayName, TokenQualifiedArrayAssign, arrayName) ]
<|> conjunction' <|> adverb' <|> function' <|> array'
Because ties and vector notation are equivalent, there is no new Branch for ties:
tokenToTree (TokenTieAssign names c ts pos) = destructureAssignment VectorAssignBranch (NE.toList names) c ts pos
Destructuring Assignment
There are four types of destructuring assignment: vector assignment, high rank assignment, tie assignment (equivalent to vector assignment) and struct assignment.
data Token
= TokenNumber (Complex Double) SourcePos
-- ...
| TokenVectorAssign [String] AssignType (NonEmpty Token) SourcePos
| TokenHighRankAssign [String] AssignType (NonEmpty Token) SourcePos
| TokenTieAssign (NonEmpty String) AssignType (NonEmpty Token) SourcePos
| TokenStructAssign [(String, Maybe (AssignType, String))] AssignType (NonEmpty Token) SourcePos
-- ...
vectorAssign :: Parser Token
vectorAssign = assign' TokenVectorAssign $ between (lexeme $ char $ fst G.vector) (lexeme $ char $ snd G.vector) (sepBy (lexeme arrayName) separator)
highRankAssign :: Parser Token
highRankAssign = assign' TokenHighRankAssign $ between (lexeme $ char $ fst G.highRank) (lexeme $ char $ snd G.highRank) (sepBy (lexeme arrayName) separator)
tieAssign :: Parser Token
tieAssign = assign' TokenTieAssign $ liftA2 (:|) (lexeme arrayName `commitOn` lexeme (char G.tie)) (sepBy (lexeme arrayName) (lexeme $ char G.tie))
structAssign :: Parser Token
structAssign = assign' TokenStructAssign $ between (lexeme $ char $ fst G.struct) (lexeme $ char $ snd G.struct) (sepBy (liftA2 (,) (lexeme anyName) (option Nothing $ Just <$> liftA2 (,) (lexeme assignArrow) (lexeme anyName))) separator)
data Tree
= Leaf { leafCategory :: Category, leafToken :: Token }
-- ...
| VectorAssignBranch { vectorAssignBranchNames :: [String], vectorAssignBranchType :: AssignType, vectorAssignBranchValue :: Tree }
| HighRankAssignBranch { highRankAssignBranchNames :: [String], highRankAssignBranchType :: AssignType, highRankAssignBranchValue :: Tree }
| StructAssignBranch { structAssignBranchNames :: [(String, Maybe (AssignType, String))], structAssignBranchType :: AssignType, structAssignBranchValue :: Tree }
-- ...
tokenToTree (TokenVectorAssign names c ts pos) = destructureAssignment VectorAssignBranch names c ts pos
tokenToTree (TokenHighRankAssign names c ts pos) = destructureAssignment HighRankAssignBranch names c ts pos
tokenToTree (TokenTieAssign names c ts pos) = destructureAssignment VectorAssignBranch (NE.toList names) c ts pos
tokenToTree (TokenStructAssign names c ts pos) = structAssignment names c ts pos
destructureAssignment :: ([String] -> AssignType -> Tree -> Tree) -> [String] -> AssignType -> NonEmpty Token -> SourcePos -> Result Tree
destructureAssignment h names ty ts pos = h names ty <$> (categorizeAndBind ts >>= requireOfCategory CatArray (\c -> makeSyntaxError pos source $ "Invalid destructure assignment of " ++ show c ++ ", array required"))
structAssignment :: [(String, Maybe (AssignType, String))] -> AssignType -> NonEmpty Token -> SourcePos -> Result Tree
structAssignment names ty ts pos = do
let ns = mapMaybe (\case { (_, Nothing) -> Nothing; (n, Just (_, n')) -> Just (n, n') }) names
mapM_ (\(n, n') -> if not $
(isArrayName n && isArrayName n') ||
(isFunctionName n && isFunctionName n') ||
(isAdverbName n && isAdverbName n') ||
(isConjunctionName n && isConjunctionName n')
then throwError $ makeSyntaxError pos source $ "Struct assignment: same type required for both the original and aliased name"
else pure ()) ns
StructAssignBranch names ty <$> (categorizeAndBind ts >>= requireOfCategory CatArray (\c -> makeSyntaxError pos source $ "Invalid struct assignment of " ++ show c ++ ", array required"))
eval (VectorAssignBranch ns c val) = eval val >>= evalVectorAssign ns c
eval (HighRankAssignBranch ns c val) = eval val >>= evalHighRankAssign ns c
eval (StructAssignBranch ns c val) = eval val >>= evalStructAssign ns c
evalVectorAssign :: [String] -> AssignType -> Value -> St Value
evalVectorAssign ns c val =
if any (\(n:_) -> n == G.quad || n == G.quadQuote) ns then throwError $ DomainError "Vector assignment: cannot assign to quad names"
else do
es <- fmap fromScalar <$> (unwrapArray (DomainError "Vector assign: not a vector") val >>= asVector (DomainError "Vector assignment: not a vector"))
if length ns /= length es then throwError $ DomainError "Vector assignment: wrong number of names"
else zipWithM_ (\name value -> evalAssign False True name c (VArray value)) ns es $> val
evalHighRankAssign :: [String] -> AssignType -> Value -> St Value
evalHighRankAssign ns c val =
if any (\(n:_) -> n == G.quad || n == G.quadQuote) ns then throwError $ DomainError "High rank assignment: cannot assign to quad names"
else do
es <- majorCells <$> unwrapArray (DomainError "High rank assign: not an array") val
if length ns /= length es then throwError $ DomainError "High rank assignment: wrong number of names"
else zipWithM_ (\name value -> evalAssign False True name c (VArray value)) ns es $> val
evalStructAssign :: [(String, Maybe (AssignType, String))] -> AssignType -> Value -> St Value
evalStructAssign ns c val = do
let err = DomainError "Struct assignment: not a struct"
s <- unwrapArray err val >>= asScalar err >>= asStruct err >>= readRef . contextScope
mapM_ (\(name, alias) -> do {
let (n, t) = case alias of {
Nothing -> (name, c)
; Just ((t', n')) -> (n', t') }
; let v = scopeShallowLookup False n s
; case v of
Nothing -> throwError $ SyntaxError $ "Struct assignment: variable " ++ n ++ " does not exist"
Just v' -> evalAssign False True name t v'
; pure () }) ns
pure val
Removing Circular
Circular is a weird function. It's sometimes called a "trenchcoat function": a function that does unrelated things based on one of the arguments. I dropped it in favor of functions in ⎕math, a quad struct.
piA :: Array
piA = scalar $ Number $ pi
complementaryS :: MonadError Error m => ScalarValue -> m ScalarValue
complementaryS (Number y) = pure $ Number $ sqrt $ 1 - y * y
complementaryS _ = throwError $ DomainError "Complementary argument must be a number"
complementaryF :: Function
complementaryF = Function (Just $ scalarMonad complementaryS) Nothing "Complementary" Nothing
sinS :: MonadError Error m => ScalarValue -> m ScalarValue
sinS (Number y) = pure $ Number $ sin y
sinS _ = throwError $ DomainError "Sine argument must be a number"
sinF :: Function
sinF = Function (Just $ scalarMonad sinS) Nothing "Sin" Nothing
arcsinS :: MonadError Error m => ScalarValue -> m ScalarValue
arcsinS (Number y) = pure $ Number $ asin y
arcsinS _ = throwError $ DomainError "Arcsine argument must be a number"
arcsinF :: Function
arcsinF = Function (Just $ scalarMonad arcsinS) Nothing "Arcsin" Nothing
cosS :: MonadError Error m => ScalarValue -> m ScalarValue
cosS (Number y) = pure $ Number $ cos y
cosS _ = throwError $ DomainError "Cosine argument must be a number"
cosF :: Function
cosF = Function (Just $ scalarMonad cosS) Nothing "Cos" Nothing
arccosS :: MonadError Error m => ScalarValue -> m ScalarValue
arccosS (Number y) = pure $ Number $ acos y
arccosS _ = throwError $ DomainError "Arccosine argument must be a number"
arccosF :: Function
arccosF = Function (Just $ scalarMonad arccosS) Nothing "Arccos" Nothing
tanS :: MonadError Error m => ScalarValue -> m ScalarValue
tanS (Number y) = pure $ Number $ tan y
tanS _ = throwError $ DomainError "Tangent argument must be a number"
tanF :: Function
tanF = Function (Just $ scalarMonad tanS) Nothing "Tan" Nothing
arctanS :: MonadError Error m => ScalarValue -> m ScalarValue
arctanS (Number y) = pure $ Number $ atan y
arctanS _ = throwError $ DomainError "Arctangent argument must be a number"
arctanF :: Function
arctanF = Function (Just $ scalarMonad arctanS) Nothing "Arctan" Nothing
sinhS :: MonadError Error m => ScalarValue -> m ScalarValue
sinhS (Number y) = pure $ Number $ sinh y
sinhS _ = throwError $ DomainError "Hyperbolic sine argument must be a number"
sinhF :: Function
sinhF = Function (Just $ scalarMonad sinhS) Nothing "Sinh" Nothing
arsinhS :: MonadError Error m => ScalarValue -> m ScalarValue
arsinhS (Number y) = pure $ Number $ asinh y
arsinhS _ = throwError $ DomainError "Hyperbolic arsine argument must be a number"
arsinhF :: Function
arsinhF = Function (Just $ scalarMonad arsinhS) Nothing "Arsinh" Nothing
coshS :: MonadError Error m => ScalarValue -> m ScalarValue
coshS (Number y) = pure $ Number $ cosh y
coshS _ = throwError $ DomainError "Hyperbolic cosine argument must be a number"
coshF :: Function
coshF = Function (Just $ scalarMonad coshS) Nothing "Cosh" Nothing
arcoshS :: MonadError Error m => ScalarValue -> m ScalarValue
arcoshS (Number y) = pure $ Number $ acosh y
arcoshS _ = throwError $ DomainError "Hyperbolic arcosine argument must be a number"
arcoshF :: Function
arcoshF = Function (Just $ scalarMonad arcoshS) Nothing "Arcosh" Nothing
tanhS :: MonadError Error m => ScalarValue -> m ScalarValue
tanhS (Number y) = pure $ Number $ tanh y
tanhS _ = throwError $ DomainError "Hyperbolic tangent argument must be a number"
tanhF :: Function
tanhF = Function (Just $ scalarMonad tanhS) Nothing "Tanh" Nothing
artanhS :: MonadError Error m => ScalarValue -> m ScalarValue
artanhS (Number y) = pure $ Number $ atanh y
artanhS _ = throwError $ DomainError "Hyperbolic artangent argument must be a number"
artanhF :: Function
artanhF = Function (Just $ scalarMonad artanhS) Nothing "Artanh" Nothing
math = Nilad (Just $ do
scope <- createRef (Scope [("pi", (VariableConstant, piA))] ((\n -> (functionRepr n, (VariableConstant, n))) <$>
[ complementaryF
, sinF
, arcsinF
, cosF
, arccosF
, tanF
, arctanF
, sinhF
, arsinhF
, coshF
, arcoshF
, tanhF
, artanhF
]) [] [] Nothing)
ctx <- get
pure $ scalar $ Struct $ ctx{ contextScope = scope } ) Nothing (G.quad : "math") Nothing
Standard Library
TinyAPL now has a standard library! It's currently very minimal, there is a math module with a reimplementation of circular and some constants; bitwise with bitwise operations; prototype with the beginning of a pseudo-prototype system that allows for overtaking.
The standard library is embedded in the executable (in TinyAPL.StandardLibrary) using Template Haskell on platforms where it's supported, and on WASM using a global initializer that gets called by a C function that's exported as the initialization function for Wizer.
#ifdef wasm32_HOST_ARCH
standardLibrary :: [([String], String)]
standardLibrary = unsafePerformIO $ listToStd <$> fileList "/std"
{-# NOINLINE standardLibrary #-}
foreign export ccall loadStandardLibrary :: IO ()
loadStandardLibrary :: IO ()
loadStandardLibrary = void $ evaluate $ rnf standardLibrary
#else
standardLibrary :: [([String], String)]
standardLibrary = listToStd $ $(ListE <$> ((runIO $ fileList "std") >>= mapM (pairToExp "std")))
#endif
Import
⎕Import is a quad name that runs a file and returns its globals in a struct. Because each system has a different notion of reading files, instead of being a normal quad name there is a function that constructs a Function for importing. It also supports overriding the standard library lookup with the default.
makeImport :: (FilePath -> St String) -> Maybe ([String] -> St String) -> Function
makeImport read readStd = Function (Just $ \x -> do
let err = DomainError "Import argument must be a character vector"
path <- asVector err x >>= mapM (asCharacter err)
ctx <- getContext
scope <- createRef $ Scope [] [] [] [] Nothing -- The scope has intentionally no parent; imports run in an isolated context
let ctx' = ctx{ contextScope = scope }
source <-
if isPrefixOf "std:" path
then case readStd of
Just fn -> fn <$> splitOn "/" $ drop (length "std:") path
Nothing -> case lookup (splitOn "/" $ drop (length "std:") path) standardLibrary of
Just source -> pure source
Nothing -> throwError $ DomainError $ "Standard library module " ++ path ++ " not found"
else read path
runWithContext ctx' $ run' path source
pure $ scalar $ Struct ctx') Nothing (G.quad : "Import") Nothing
Done!
That's it, you've finally reached the end of the article! TinyAPL is, in my opinion, way more usable now, so it's a great time to try it out.