Mono Stacking Machine

  • Tutorial

Not so long ago, an excellent and inspiring article about compilers and stack machines appeared on Habré . It shows the path from a simple implementation of the bytecode artist to more and more efficient versions. I wanted to show, using the example of the development of a stack machine, how to do this in Haskell-way.


Using the example of language interpretation for a stack machine, we will see how the mathematical concept of semigroups and monoids helps to develop and expand the program architecture, how one can use algebra of monoids, and how one can build programs in the form of a set of homomorphisms between algebraic systems. As working examples, we first build an interpreter that is inseparable from the code in the form of an EDSL, and then we will teach it different things: record arbitrary debugging information, separate the program code from the program itself, carry out a simple static analysis and calculate with various effects.


The article is intended for those who speak Haskell at an average level and above, for those who already use it in work or research, and for all curious people who have looked at what it is that the functionals have yet realized. Well, for those, of course, who did not scare the previous paragraph.


There was a lot of material, with a lot of examples in the code, and to make it easier for the reader to understand whether he needs to dive into it, I’ll give an annotated content.


The content of the article
  • Languages ​​and programs for stack machines. We consider the structural features of the languages ​​of stack machines that can be used to implement the interpreter.
  • Build a car. The interpreter code for a stack machine with memory, based on transformation monoids, is more or less detailed.
  • Комбинируем моноиды.С помощью алгебры моноидов добавляем в интерпретатор ведение журнала вычислений, с практически произвольными типами записей.
  • Программы и их коды.Строим изоморфизм между программой и её кодом, дающий возможность оперировать ими по-отдельности.
  • Освобождение моноида.Новые гомомофизмы из программ в другие структуры используютсях для форматированного листинга, статического анализа и оптимизации кода.
  • От моноидов к монадам и снова к моноидам.Конструируем гомоморфизмы в элементы категории Клейсли, открывающие возможности использования монад. Расширяем интерпретатор командами ввода/вывода и неоднозначными вычислениями.

The tasks of translation and interpretation present many interesting and useful examples to demonstrate various aspects of programming. They allow you to go to different levels of complexity and abstraction, while remaining quite practical. In this article we will focus on demonstrating the capabilities of two important mathematical structures - a semigroup and a monoid . They are not so often discussed as monads or lenses, and they are not afraid of little programmers, these structures are much easier to understand, but with all that, they are the basis of functional programming. Masterly mastery of monoidal types, which is demonstrated by professionals, is admired by the simplicity and elegance of the solutions.


The search for the word "monoid" on the articles on Habré produces no more than four dozen articles (about the same monads, for example, there are three hundred of them). All of them conceptually start with something like: a monoid is such a lot ... and then, with quite understandable delight, list what is a monoid - from lines to finger trees, from regular expression parsers to God knows what else ! But in practice we think in reverse order: we have an object that needs to be modeled, we analyze its properties and find that it possesses the characteristics of an abstract structure, decide whether we need consequences from this circumstance and how we use it. We will go this way. And at the same time we will add a couple of interesting examples to the collection of useful monoids.



Languages ​​and programs for stack machines


Stack machines, when studying functional programming, usually appear at the moment when they approach the concept of convolution. In this case, an extremely laconic implementation of the performer of the simplest stack calculator is given, for example, this:


Simple Stack Calculator
calc :: String -> [Int]
calc = interpretor . lexer
  where
    lexer = words
    interpretor = foldl (flip interprete) []
    interprete c = case c of"add" -> binary $ \(x:y:s) -> x + y:s
      "mul" -> binary $ \(x:y:s) -> x * y:s
      "sub" -> binary $ \(x:y:s) -> y - x:s
      "div" -> binary $ \(x:y:s) -> y `div` x:s
      "pop" -> unary  $ \(x:s) -> s
      "dup" -> unary  $ \(x:s) -> x:x:s
      x -> case readMaybe x ofJust n -> \s -> n:s
        Nothing -> error $ "Error: unknown command " ++ c
      where
        unary f s = case s of
          x:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected an argument."
        binary f s = case s of
          x:y:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected two arguments."

This uses the total parser readMaybefrom the module Text.Read. It would be possible to bring the program two times shorter, but already without informative error messages, and this is ugly.


Great start to talk! Then, as a rule, they start to add effects: they change the convolution foldlto foldM, provide totality through the monad Either String, then add logging, wrapping everything with a transformer WriterT, introduce it with the help of a StateTdictionary for variables, and so on. Sometimes, to demonstrate the coolness of monadic calculations, an ambiguous calculator is implemented that returns all possible values ​​of the expression$ (2 \ pm 3) * ((4 \ pm 8) \ pm 5) $. This is a long, good and interesting conversation. However, we will immediately lead our story differently, although we will end it with the same result.


Why, in general, is it about convolution? Because convolution (cathamorphism) is an abstraction of sequential processing of inductive data . A stack machine runs linearly through the code, following a sequence of instructions and generating one value — the state of the stack. I like to imagine the work of a convolutional stack machine as a translation of messenger RNA in a living cell. The ribosome, step by step, goes through the entire RNA chain, compares the nucleotide triplets with amino acids and creates the primary structure of the protein.


The convolutional machine has a number of restrictions, the main one is that the program is always read from beginning to end and once. Branching, loops, and subroutine calls require a conceptual change to the interpreter. Nothing complicated, of course, but such a machine can no longer be described by a simple convolution.


According to the hypothesis of linguistic relativity, the properties of the language we use directly affect the properties of our thinking. Let's pay attention not to the machine, but to the languages and programs by which it is controlled.


All stack-oriented languages, both relatively low-level (bytecodes of the Java and Python or .NET virtual machines) and languages ​​at a higher level (PostScript, Forth or Joy), have one fundamental common feature: if you write successively two correct programs, then get the correct program. True, correct does not mean "correct", this program may crash on any data or fall into infinite loops and generally do not make sense, but the main thing is that such a program can be executed by a machine. At the same time, breaking the correct program into parts, we can easily reuse these parts, precisely because of their correctness. Finally, in any stack language, you can select a subset of commands that operate only on the internal state of the machine (stack or registers) that do not use any external memory.concatenativeness . In such a language, any program has the meaning of a state machine transducer, and the sequential execution of programs is equivalent to their composition, which means it is also a state transducer.


The general pattern is viewed: the combination (concatenation) of correct programs generates the correct program, the combination of transducers generates the transducer. It turns out that the stack language programs are closed with respect to the concatenation operation or form a structure called a groupoid or magma . This means that, writing a program onto a tape, it is possible to cut it almost haphazardly and then form new programs from the resulting segments. And you can cut up to segments with a single instruction.


When gluing important order. For example, these two programs are undoubtedly different:

$ \ texttt {5 dup pop} \ neq \ texttt {5 pop dup}. $


But it doesn’t matter where we cut the program, if we merge it here in this place:

$ (\ texttt {5 dup}) + \ texttt {pop} = \ texttt {5} + (\ texttt {dup pop}). $


This simple circumstance reflects the associativity of the concatenation operation and takes the structure that the stack programs form to a new level, we understand that this is a semigroup .

And what does this give us, as programmers? Associativity allows you to precompile, optimize and even parallelize arbitrary suitable segments of the program, and then combine them into an equivalent program. We can afford to carry out a static analysis of any segment of the program and use it in the analysis of the entire program precisely because we do not care where to put the brackets. These are very important and serious opportunities for a low-level language or an intermediate language in which not a person writes, but a translator. And from the point of view of a mathematician and a well-established functionary, this makes the state-transformer programs of the state of the machine complete endomorphisms . Endomorphisms also form a semigroup with the operation of composition. In algebra such endomorphisms are called transformation semigroups.in relation to any set. For example, finite automata form a semigroup of transformation of a set of states.


"Semigroup" sounds half-heartedly, somehow defective. Maybe stack programs form a group ? E ... no, most programs are irreversible, that is, it will not work out by the result of the execution to unambiguously restore the original data. But we have a neutral element. In assembly languages, it is denoted$ \ texttt {nop} $and does nothing. If in the stack language such an operator is not explicitly defined, then it can be easily obtained by combining some commands, for example:$ \ texttt {inc dec} $, $ \ texttt {dup pop} $ or $ \ texttt {swap swap} $. Such pairs can be painlessly cut from programs or, on the contrary, inserted anywhere in any number. Since there is a unit, our programs form a semigroup with a unit or a monoid . So, you can programmatically implement them in the form of monoids - endomorphisms over the state of the stack machine. This will allow you to define a small set of basic operations for the machine, and then create programs using their composition, getting a stack language in the form of an embedded object-oriented language (EDSL).


In Haskell, semigroups and monoids are described using the classes Semigroupand Monoid. Their definitions are simple and reflect only the basic structure, the requirements of associativity and neutrality have to be checked by the programmer:


classSemigroup a where
  (<>) :: a -> a -> a
classSemigroup a => Monoid a where
  mempty :: a


Build a car


Header of the program
{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-}import Data.Semigroup (Max(..),stimes)
import Data.Monoid
import Data.Vector ((//),(!),Vector)
importqualified Data.Vector as V (replicate)

We will immediately build a machine that has a stack, a finite memory, and can crash in an amicable, clean way. We implement all this without the use of monads, encapsulating the necessary data in the type describing the machine. Thus, all the basic programs, and therefore all their combinations, will be pure converters of its state.


We start by defining the type for the virtual machine and the trivial setter functions.


typeStack = [Int]typeMemory = VectorInttypeProcessor = VM -> VMmemSize = 4dataVM = VM { stack :: Stack
             , status :: MaybeString
             , memory :: Memory }derivingShowemptyVM = VM mempty mempty (V.replicate memSize 0)
setStack :: Stack -> ProcessorsetStack  x (VM _ s m) = VM x s m
setStatus :: MaybeString -> ProcessorsetStatus x (VM s _ m) = VM s x m
setMemory :: Memory -> ProcessorsetMemory x (VM s st _) = VM s st x

Setters are needed to make the semantics of the program explicit. By processor (type Processor) we will mean a converter VM -> VM.


Now we define the wrapper types for the transformation monoid and for the program:


instanceSemigroup (Actiona) whereAction f <> Action g = Action (g . f)
instanceMonoid (Actiona) where
  mempty = Action id
newtypeProgram = Program { getProgram :: ActionVM }deriving (Semigroup, Monoid)

Types of wrappers define the principle of combining programs: these are endomorphisms with the reverse order of the composition (from left to right). Using wrappers allows the compiler to independently determine how the type Programimplements the requirements of the Semigroupand classes Monoid.


Performer programs is trivial:


run :: Program -> Processorrun = runAction . getProgram
exec :: Program -> VMexec prog = run prog emptyVM

The error message will be generated by the function err:


err :: String -> Processorerr = setStatus . Just $ "Error! " ++ m

We use the type Maybenot as it is used normally: an empty value Nothingin the status means that nothing dangerous happens, and the calculations can be continued, in turn, the string value marks the problem. For convenience, we define two smart constructors: one for programs that work only with the stack, the other for those who need memory.


program :: (Stack -> Processor) -> Programprogram f = Program . Action $
  \vm -> case status vm ofNothing -> f (stack vm) vm
    _ -> vm
programM :: ((Memory, Stack) -> Processor) -> ProgramprogramM f = Program . Action $
  \vm -> case status vm ofNothing -> f (memory vm, stack vm) vm
    _ -> vm

Now you can define basic language commands for working with the stack and memory, integer arithmetic, as well as equivalence and order relations.


Work with stack
pop = program $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."push x = program $ \s -> setStack (x:s)
dup = program $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."swap = program $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."exch = program $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "exch expected two arguments."

Work with memory
-- конструктор для функций с ограниченным индексомindexed i f = programM $ if (i < 0 || i >= memSize)
                         then const $ err $ "expected index in within 0 and " ++ show memSize
                         else f
put i = indexed i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "put expected an argument"get i = indexed i $ \(m, s) -> setStack ((m ! i) : s)

Arithmetic operations and relationships
unary n f = program $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show n ++ " expected an argument"binary n f = program $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show n ++ " expected two arguments"add = binary "add" (+)
sub = binary "sub" (flip (-))
mul = binary "mul" (*)
frac = binary "frac" (flip div)
modulo = binary "modulo" (flip mod)
neg = unary "neg" (\x -> -x)
inc = unary "inc" (\x -> x+1)
dec = unary "dec" (\x -> x-1)
eq = binary "eq" (\x -> \y -> if (x == y) then1else0)
neq = binary "neq" (\x -> \y -> if (x /= y) then1else0)
lt = binary "lt" (\x -> \y -> if (x > y) then1else0)
gt = binary "gt" (\x -> \y -> if (x < y) then1else0)

To complete the work is not enough branching and cycles. In fact, for a built-in language, only branching is sufficient, cycles can be organized using recursion in the host language (in Haskell), but we will make our language self-sufficient. In addition, we use the fact that the programs form a semigroup and define a combinator of program repetition a specified number of times. The number of repetitions he will take from the stack.


Branching and loops
branch :: Program -> Program -> Programbranch br1 br2 = program go
   where go (x:s) = proceed (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."while :: Program -> Program -> Programwhile test body = program (const go) 
  where go vm = let res = proceed test (stack vm) vm
          incase (stack res) of0:s -> proceed mempty s res
               _:s -> go $ proceed body s res
               _ -> err "while expected an argument." vm
rep :: Program -> Programrep body = program go
  where go (n:s) = proceed (stimes n body) s
        go _ = err "rep expected an argument."proceed :: Program -> Stack -> Processorproceed prog s = run prog . setStack s

The types of functions branchalso whilesuggest that these are not stand-alone programs, but program combinators: a typical approach when creating an EDSL in Haskell. The function is stimesdefined for all semigroups, it returns the composition of the specified number of elements.


Finally, we will write several programs for experiments.


Examples of programs
-- рекурсивный факториалfact = dup <> push 2 <> lt <>
       branch (push 1) (dup <> dec <> fact) <>
       mul
-- итеративный факториалfact1 = push 1 <> swap <>
        while (dup <> push 1 <> gt) 
        (
         swap <> exch <> mul <> swap <> dec
        ) <> 
        pop
-- заполняет стек последовательностью чисел-- в указанном диапазонеrange = exch <> sub <> rep (dup <> inc)
-- ещё один итеративный факториал,-- записанный через свёртку списка командfact2 = mconcat [ dec, push 2, swap, range, push 3, sub, rep mul]
-- итеративный факториал с использованием памятиfact3 = dup <> put 0 <> dup <> dec <>
        rep (dec <> dup <> get 0 <> mul <> put 0) <>
        get 0 <> swap <> pop
-- копирует два верхних элемента стекаcopy2 = exch <> exch
-- вычисляет наибольший общий делитель -- по простейшему алгоритму Евклидаgcd1 = while (copy2 <> neq) 
       (
         copy2 <> lt <> branch mempty (swap) <> exch <> sub
       ) <>
       pop
-- возведение в степень методом русского крестьянинаpow = swap <> put 0 <> push 1 <> put 1 <>
      while (dup <> push 0 <> gt)
      (
        dup <> push 2 <> modulo <>
        branch (dec <> get 0 <> dup <> get 1 <> mul <> put 1) (get 0) <>
        dup <> mul <> put 0 <>
        push 2 <> frac
      ) <>
      pop <> get 1

It turned out 120 lines of code with comments and type annotations that define a machine operating with 18 teams with three combinators. This is how our machine works.


λ> exec (push 6 <> fact)
VM {stack = [720], status = Nothing, memory = [0,0,0,0]}
λ> exec (push 6 <> fact3)
VM {stack = [720], status = Nothing, memory = [720,0,0,0]}
λ> exec (push 2 <> push 6 <> range)
VM {stack = [6,5,4,3,2], status = Nothing, memory = [0,0,0,0]}
λ> exec (push 6 <> push 9 <> gcd1)
VM {stack = [3], status = Nothing, memory = [0,0,0,0]}
λ> exec (push 3 <> push 15 <> pow)
VM {stack = [14348907], status = Nothing,  memory = [43046721,14348907,0,0]}
λ> exec (push 9 <> add)
VM {stack = [9], status = Just"Error! add expected two arguments", memory = [0,0,0,0]}

In fact, we have not done anything new - by combining transformers-endomorphisms, we essentially returned to the convolution, but it became implicit. Recall that a convolution gives an abstraction of sequential processing of inductive data. Data, in our case, is formed in an inductive way when pasting programs by the operator$ \ diamond $, and they are “stored” in endomorphism in the form of a chain of compositions of functions of machine transformers until this chain is applied to the initial state. In the case of the use of combinators branchand the whilechain begins to turn into a tree or a cycle. In the general case, we obtain a graph that reflects the operation of the automaton with the store memory, that is, the stack machine. It is this structure that we "turn off" during the execution of the program.


How effective is this implementation? The composition of functions is the best that the Haskell compiler can do. He is literally born for this! When it comes to the benefits of using knowledge of monoids, an example of difference lists diffListis often given - the implementation of a linked list in the form of a composition of endomorphisms. Difference lists fundamentally accelerate the formation of lists of many pieces due to the associativity of the composition of functions. Fussing with wrapper types does not lead to an increase in overhead costs, they "dissolve" at the compilation stage. Of the extra work there is only a state check at each step of the program execution.



We combine monoids


I think by this point skeptics and casual readers have already left us, you can afford to relax and go to the next level of abstraction.


The concept of semigroups and monoids would not be so useful and universal, if not a number of properties inherent in all semigroups and monoids without exception, which allow us to construct complex structures from simple structures in exactly the same way as we build complex programs from simple ones. These properties are no longer related to objects, but to types and are best written not in mathematical notation, but in the form of Haskell programs, which, by virtue of the Curry-Howard isomorphism, are their proofs.


1) Monoids and semigroups can be “multiplied”. What is meant here is a product of types whose abstraction in Haskell is a tuple or a pair.


instance (Semigroupa, Semigroupb) => Semigroup (a,b) where
    (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2)
instance (Monoida, Monoidb) => Monoid (a,b) where
    mempty = (mempty, mempty )

2) There is a single monoid, it is represented by a single type ():


instanceSemigroup () where
    () <> () = ()
instanceMonoid () where
    mempty = ()

With the multiplication operation, the semigroups themselves form a semigroup, and taking into account the unit type, we can say that monoids form a monoid! The associativity and neutrality of the unit is fulfilled with an accuracy of isomorphism, but this is not fundamental.


3) Mappings into a semigroup or monoid form, respectively, a semigroup or monoid. And here, too, it is easier to write this statement in Haskell:


instanceSemigroup a => Semigroup (r -> a) where
  f <> g = \r -> f r <> g r
instanceMonoid a => Monoid (r -> a) where
  mempty = const mempty

We use these combinators to expand the capabilities of the stack language we have constructed. Let's make a major change and make our basic commands functions that return programs . This will not deprive them of monoidal properties, but it will allow to enter into the work of all the commands of the machine arbitrary information from the outside. This is what is meant:


(command1 <> command2) r   ==  command1 r <> command2 r

Information can be any, for example, an external dictionary with some definitions, or a way to keep a journal of calculations, which is necessary when debugging. This is very similar to the action of the monad Reader, which is just a function.


We will enter a log into the structure of the machine, but we will not bind it to any particular type, but will output it into a type parameter. We will write to the journal with the help of a generalized monoidal operation.


dataVM a = VM { stack :: Stack
               , status :: MaybeString
               , memory :: Memory
               , journal :: a }derivingShowmkVM = VM mempty mempty (V.replicate memSize 0)
setStack  x (VM _ st m l) = VM x st m l
setStatus st (VM s _ m l) = VM s st m l
setMemory m (VM s st _ l) = VM s st m l
addRecord x (VM s st m j) = VM s st m (x<>j)
newtypeProgram a = Program { getProgram :: Action (VMa) }deriving (Semigroup, Monoid)
typeProgram' a = (VMa -> VMa) -> Program a

From this point on, we allow ourselves not to specify the type annotations for all definitions, leaving the compiler to deal with them on their own, they are not complicated, although they become cumbersome. The teams themselves will not have to change, thanks to smart designers who will take over all the changes. Very small.


New designers and combinators.
program f p = Program . Action $
  \vm -> case status vm ofNothing -> p . (f (stack vm)) $ vm
    m -> vm
programM f p = Program . Action $
  \vm -> case status vm ofNothing -> p . (f (memory vm, stack vm)) $ vm
    m -> vm
proceed p prog s = run (prog p) . setStack s
rep body p = program go id
  where go (n:s) = proceed p (stimes n body) s
        go _ = err "rep expected an argument."branch br1 br2 p = program go id
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."while test body p = program (const go) id
  where go vm = let res = proceed p test (stack vm) vm
          incase (stack res) of0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "while expected an argument." vm

It remains to learn to enter external information into the programmer. This is very easy to do by creating different artists with a different journaling strategy. The first performer will be the most simple, silent, not wasting his time on keeping a journal:


exec prog = run (prog id) (mkVM ())

Here a single monoid was useful to us ()- a neutral element in the algebra of monoids. Further, it is possible to define a function for a contractor who is ready to record some information about the state of the machine in the log.


execLog p prog = run (prog $ \vm -> addRecord (p vm) vm) (mkVM mempty)

Information may be, for example, such:


logStack vm   = [stack vm]
logStackUsed  = Max . length . stack
logSteps      = const (Sum1)
logMemoryUsed = Max . getSum . count . memory
  where count = foldMap (\x -> if x == 0then0else1)

We check the work:


λ> exec (push 4 <> fact2)
VM {stack = [24], status = Nothing, memory = [0,0,0,0], journal = ()}
λ> journal $ execLog logSteps (push 4 <> fact2)
Sum {getSum = 14}
λ> mapM_ print $ reverse $ journal $ execLog logStack (push 4 <> fact2)
[4]
[3]
[2,3]
[3,2]
[2,2]
[3,2]
[3,3,2]
[4,3,2]
[4,4,3,2]
[5,4,3,2]
[3,5,4,3,2]
[2,4,3,2]
[12,2]
[24]

Loggers can be combined using the fact that monoids are multiplied. We introduce a simple combinator for loggers:


f &&& g = \r -> (f r, g r)

So you can compare the four implementations of factorial by the number of steps and the maximum stack length


λ> let report p = journal $ execLog (logSteps &&& logStackUsed) p
λ> report (push 8 <> fact)
(Sum {getSum = 48},Max {getMax = 10})
λ> report (push 8 <> fact1)
(Sum {getSum = 63},Max {getMax = 4})
λ> report (push 8 <> fact2)
(Sum {getSum = 26},Max {getMax = 9})
λ> report (push 8 <> fact3)
(Sum {getSum = 43},Max {getMax = 3})

Loggers could be declared a monoid with an operation &&&if they all returned the same type. But since they are different, Haskell does not allow this. So not everything that is combined is a working monoid.



Programs and their codes


Full debugging implies information about the executed commands. But our teams are real functions, they have no name outside the Haskell namespace. And here we come to a beautiful argument.


Each basic command can be associated with a unique code, while at the same time, it can be associated with a code — a command. Both matches are single-valued, which means that the sets of commands and names are isomorphic . Programs (command combinations) form a monoid, and program texts (sequence of codes) form a monoid. We started the conversation by cutting and gluing exactly the texts of the programs recorded on tapes. This means that a pair of mutually inverse homomorphisms can be constructed between programs and their codes .


Let's build these maps! We first define the type for the codes of our language:


dataCode = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUTInt | GETInt
          | PUSHInt | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV
          | EQL | LTH | GTH | NEQderiving (Read, Show)

Now we will construct a homomorphism code $ \ rightarrow $ program:


fromCode :: [Code] -> Program' a
fromCode = hom
  where
    hom = foldMap $ \caseIF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg

Here we use the fact that the programs are monoids. foldMapthis is an effective convolution for monoids and using the associativity of monoidal operations. Homomorphism fromCodeis a program translator written in codes, it already allows you to broadcast programs recorded in the form of codes and even in the form of a text:


λ> stack $ exec (fromCode [PUSH2, PUSH5, EXCH, SUB, REP [DUP, INC]])
[5,4,3,2]
λ> stack $ exec (fromCode $ read "[PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]]")
[5,4,3,2]

Reverse homomorphism program$ \ rightarrow $code to build in the same way will not work, because we can not iterate into casefunctions. But you can again use two remarkable circumstances: the fact that the programs form a monoid and the fact that the monoids form a semigroup! Multiply in determining the type of Programprogram code and the corresponding transformer:


newtypeProgram a = Program { getProgram :: ([Code], Action (VMa)) }deriving (Semigroup, Monoid)
run = runAction . snd . getProgram

Along with the performing function run, it is possible to get the program code and here it is the second homomorphism, the opposite fromCode:


toCode :: Program' a -> [Code]
toCode prog = fst . getProgram $ prog id

It now remains to rewrite the expressions for smart designers so that each basic program can specify its code. However, the constructors and definitions of language commands will not change significantly:


typeProgram' a = (Code -> VMa -> VMa) -> Program aprogram c f p = Program . ([c],) . Action $
  \vm -> case status vm ofNothing -> p c . f (stack vm) $ vm
    _ -> vm
programM c f p = Program . ([c],) . Action $
  \vm -> case status vm ofNothing -> p c . f (memory vm, stack vm) $ vm
    _ -> vm

As you can see, the function that we pass to logging has become binary, since it now has the program code. So you need to change the loggers a little, and in one create a logger for the code and a talkative logger debugger:


Loggers and debugger
none = const id
exec prog = run (prog none) (mkVM ())
execLog p prog = run (prog $ \c -> \vm -> addRecord (p c vm) vm) (mkVM mempty)
logStack _ vm = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _ = const (Sum1)
-- новые логгерыlogCode c _ = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')
debug :: Program' [String] -> Stringdebug = unlines . reverse . journal . execLog logRun

Definitions of Named Base Commands and Combinators
pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "POP expected an argument."push x = program (PUSH x) $ \s -> setStack (x:s)
dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "DUP expected an argument."swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "SWAP expected two arguments."exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "EXCH expected two arguments."app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then1else0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then1else0)
lt = app2 LTH (\x -> \y -> if (x > y) then1else0)
gt = app2 GTH (\x -> \y -> if (x < y) then1else0)
proceed p prog s = run (prog p) . setStack s
rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0then proceed p (stimes n body) s
                   else err "REP expected positive argument."
        go _ = err "REP expected an argument."branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "IF expected an argument."while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = let res = proceed p test (stack vm) vm
          incase (stack res) of0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "WHILE expected an argument." vm
put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "PUT expected an argument"get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)
indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"else f

Everything, an isomorphism between programs and their codes is established! Let's see how it works.


First, we can get the code of any program:


λ>  toCode fact1
[PUSH1,SWAP,WHILE [DUP,PUSH1,GTH] [SWAP,EXCH,MUL,SWAP,DEC],POP]

Now programs can be created using EDSL, write them to a file and read from it.


Second, we can verify that the two homomorphisms toCodeand fromCodeare mutually inverse.


λ> toCode $ fromCode [PUSH5, PUSH6, ADD]
[PUSH5, PUSH6, ADD]
λ> exec (fromCode $ toCode (push 5 <> push 6 <> add))
VM {stack = [11], status = Nothing, memory = [0,0,0,0], journal = ()}

True, our isomorphism has one major drawback: it does not allow turning into a final program code, defined using explicit recursion. Try to ghcisee the program code fact, just keep your fingers ready to quickly press Ctrl+C. We have to admit that the homomorphism toCodeexists, but we can partially calculate it.


Finally, let's run a full-fledged debugger, moreover, it works just fine with recursive functions too:


λ> putStrLn $ debug (push 3 <> fact)
PUSH3    | 3                   | 0000DUP       | 33                 | 0000PUSH2    | 233               | 0000LTH       | 03                 | 0000DUP       | 33                 | 0000DEC       | 23                 | 0000DUP       | 223               | 0000PUSH2    | 2223             | 0000LTH       | 023               | 0000DUP       | 223               | 0000DEC       | 123               | 0000DUP       | 1123             | 0000PUSH2    | 21123           | 0000LTH       | 1123             | 0000PUSH1    | 1123             | 0000MUL       | 123               | 0000MUL       | 23                 | 0000MUL       | 6                   | 0000


Monoid release


The program code has the appearance of a tree and it represents pure information about the program. We got free algebra programs for our stack machine. Moreover, the programs themselves are free structures, since we built an isomorphism between the program code and the performer!


In addition to the possibilities of serialization and deserialization, free structures provide freedom of interpretation. So far we have built only one way to interpret a free program - in the form of transformations of the state of a stack machine. But having a free-form program you can do anything with it, for example, to provide formatted output, to carry out optimization or static analysis.


Usually, at this wonderful passage, an article about free structures ends: you can and you can, though it’s difficult and not to tell in one section. But it turned out that our language is extremely simple and extremely monoidal, and this allows us to do some things very elegantly. Sin is not to take advantage and not to share!


Here, for example, how easy it is to write a formatted program listing:


listing :: Program' a -> Stringlisting = unlines . hom 0 . toCode
  where
    hom n = foldMap f
      where
        f = \caseIF b1 b2 -> ouput "IF" <> indent b1 <> ouput ":" <> indent b2
          REP p -> ouput "REP" <> indent p
          WHILE t b -> ouput "WHILE" <> indent t <> indent b
          c -> ouput $ show c
        ouput x = [stimes n "  " ++ x]
        indent = hom (n+1)

And again a homomorphism is built: now the teams are mapped to indented lines, which, again, form a monoid.


A couple of nicely printed programs:
λ> putStrLn . listing $ fact2
INCPUSH1SWAPEXCHSUBDUPPUSH0GTHIFREPDUPINC
:
  NEGREPDUPDECDECDECREPMUL
λ> putStrLn . listing $ gcd1
WHILEEXCHEXCHNEQEXCHEXCHLTHIF
  :
    SWAPEXCHSUBPOP

We will not dwell on this and try to conduct a simple static analysis of programs for a stack machine. We have one data type, so static typing is not relevant for the language, but there may not be enough data on the stack to run the program. We have the ability to calculate strict requirements for the program to work before it is executed.


We introduce such a characteristic of programs as valence - this is information about the maximum number of arguments that must be on the stack before its execution and about the minimum number of elements that will remain on the stack after its execution. For example, before performing the addition operation, you need to have at least two elements on the stack, and after the execution, at least one element remains. We will write this circumstance in this form:

$ \ mathrm {arity} (\ texttt {add}) = 2 \ triangleright 1 $


Here are the valencies of some other operators:

$ \ mathrm {arity} (\ texttt {push}) = 0 \ triangleright 1 \\ \ mathrm {arity} (\ texttt {pop}) = 1 \ triangleright 0 \\ mathrm {arity} (\ texttt {exch} ) = 2 \ triangleright $ 3


Why do we always make a reservation: the minimum number, the maximum requirements ..? The point is that all basic operators have exactly defined valence, but when branching, different branches may have different requirements and results. Our task: to calculate the most stringent requirements that should ensure the work of all branches, no matter how many.

When sequentially executing commands, valencies are combined in the following nontrivial way:

$ (i_1 \ triangleright o_1) \ diamond (i_2 \ triangleright o_2) = (a + i_1) \ triangleright (a + o_1 + o_2 - i_2), \ qquad a = \ max (0, i_2 - o_1). $


This operation is associative and has a neutral element, which is not surprising for an article on monoids. Add this result to the program:
infix7 :>
dataArity = Int :> Intderiving (Show,Eq)
instanceSemigroupAritywhere
  (i1 :> o1) <> (i2 :> o2) = let a = 0 `max` (i2 - o1)
                             in (a + i1) :> (a + o1 + o2 - i2)
instanceMonoidAritywhere
  mempty = 0:>0

And then you can build a homomorphism:


arity :: Program' a -> Arityarity = hom . toCode
  where
    hom = foldMap $
      \caseIF b1 b2 -> let i1 :> o1 = hom b1
                        i2 :> o2 = hom b2
                    in1:>0 <> (i1 `max` i2):>(o1 `min` o2)
        REP p -> 1:>0WHILE t b -> hom t <> 1:>0PUT _ -> 1:>0GET _ -> 0:>1PUSH _ -> 0:>1POP -> 1:>0DUP -> 1:>2SWAP -> 2:>2EXCH -> 2:>3INC -> 1:>1DEC -> 1:>1NEG -> 1:>1
        _   -> 2:>1

The cycle combinators have a valence independent of the cycle body, since the body code may not be executed at all when the program is executed. And since we are considering strict requirements, we can say for sure that only a check on the entrance to the cycle is guaranteed.


Calculate the requirements for some programs (except recursive):


λ> arity (exch <> exch)
2 :> 4
λ> arity fact1
1 :> 1
λ> arity range
2 :> 1
λ> arity (push 3 <> dup <> pow)
0 :> 1

What else can you count before doing it? Since the memory registers are specified statically, each program "knows" how much memory it needs. You can build a homomorphism Program' a -> Max Int, and when you initialize the machine to create a region of memory of the desired volume. It can be built, for example, like this:


memoryUse :: Program' a -> MaxIntmemoryUse = hom . toCode
  where
    hom = foldMap $
      \caseIF b1 b2 -> hom b1 <> hom b2
        REP p -> hom p
        WHILE t b -> hom t <> hom b
        PUT i -> Max (i+1)
        GET i -> Max (i+1)
        _ -> 0

λ> memoryUse fact1
Max {getMax = 0}
λ> memoryUse fact3
Max {getMax = 1}
λ> memoryUse pow
Max {getMax = 2}

When concatenating programs, there may be conflicts with memory sharing. This can be solved automatically by entering the appropriate offsets for all indexes indicated, because the memory requirements are available before the program runs.


Calculation of valence allows for a simple, but effective optimization: you can select the longest continuous linear segments of programs that do not require elements on the stack before execution, that is, with valence 0:>_and do not use memory. Such chains do not depend on the current data and can be calculated in advance and replaced by the result at the broadcasting stage. This is usually arithmetic.


An example of building an optimizer
isReducible p = let p' = fromCode p
                incase arity p' of0:>_ -> memoryUse p' == 0
                     _    -> Falsereducible = go [] . toCode
  where go res [] = reverse res
        go res (p:ps) = if isReducible [p]
                        thenlet (a,b) = spanBy isReducible (p:ps)
                             in go (a:res) b
                        else go res ps
-- здесь используется моноид Last, который комбинируется,-- оставляя последний нетривиальный результатspanBy test l = case foldMap tst $ zip (inits l) (tails l) ofLastNothing -> ([],l)
                  Last (Just x) -> x
  where tst x = Last $ if test (fst x) thenJust x elseNothing-- здесь используется моноид Endo комбинирующийся как эндоморфизм-- функции intercalate и splitOn можно подгрузить из библиотек-- Data.List и Data.List.Splitreduce p = fromCode . process (reducible p) . toCode $ p
  where
    process = appEndo . foldMap (\x -> Endo $ x `replaceBy` shrink x)
    shrink = toCode . foldMap push . reverse . stack . exec . fromCode
    replaceBy x y = intercalate y . splitOn x

An example of optimizing a simple program:


λ> let p = push 6 <> fact1 <> swap <> push 5 <> dup <> push 14 <> gcd1 <> put 1
λ> toCode $ p
[PUSH6,PUSH1,SWAP,WHILE [DUP,PUSH1,GTH] 
[SWAP,EXCH,MUL,SWAP,DEC],POP,SWAP,PUSH5,DUP,PUSH14,WHILE 
[EXCH,EXCH,NEQ] [EXCH,EXCH,LTH,IF [] [SWAP],EXCH,SUB],POP,PUT1]
λ> toCode $ reduce p
[PUSH720,SWAP,PUSH5,PUSH1,PUT1]
λ> execLog logSteps (push 8 <> p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 107}}
λ> execLog logSteps (push 8 <> reduce p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 6}}

Optimization has reduced the number of steps needed by the program from 107 to 6.


Further, from the valence one can go, say, to the Hoare triples and formally verify the programs, deriving logical pre- and post-conditions for the operation of the linear sections of the programs (for the cycles one has to tinker with invariants).



From monoids to monads and again to monoids


But what if our car needs to go into the world of effects: communicate with the user, with the file system, database, random numbers, etc.? Is it possible to equip our solution with monadic calculations? It is possible, although it is necessary to rewrite the implementation, but it's worth it!


When using monads, the mtransformers VM -> VMmust turn into VM -> m VM, this is no longer an endomorphism. But remember the catch phrase: "Monad is just a monoid in the category of endofunctors, what's the problem ?!" In the category Kleisli, which form the converters VM -> m VM, the composition is defined, and it, according to the rules of the categories, is associative and has a neutral element. This composition in Haskell is designated by the operator >=>and is called "Kleysli fish". So, to enter the world of computation with effects, it is enough to change the filling Actionfor a monoid ActionM, defining it as follows:


newtypeActionM m a = ActionM { runActionM :: a -> ma }instanceMonad m => Semigroup (ActionMma) whereActionM f <> ActionM g = ActionM (f >=> g)
instanceMonad m => Monoid (ActionMma) where
  mempty = ActionM return

Setters will change, they should become monadic, and everywhere instead of their composition, you will have to use an operator >=>. All other definitions will remain unchanged.


Monadic computing stack machine
{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, TupleSections #-}import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..),stimes,Max(..))
import Data.Vector ((//),(!),Vector,toList)
importqualified Data.Vector as V (replicate)
import Control.Monad
import Control.Monad.Identity
typeStack = [Int]typeMemory = VectorIntmemSize = 4dataVM a = VM { stack :: Stack
               , status :: MaybeString
               , memory :: Memory
               , journal :: a }derivingShowmkVM = VM mempty mempty (V.replicate memSize 0)
setStack  x (VM _ st m l) = return $ VM x st m l
setStatus st (VM s _ m l) = return $ VM s st m l
setMemory m (VM s st _ l) = return $ VM s st m l
addRecord x (VM s st m l) = VM s st m (x<>l)
------------------------------------------------------------dataCode = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUTInt | GETInt
          | PUSHInt | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV | MOD
          | EQL | LTH | GTH | NEQ
          | ASK | PRT | PRTSString
          | FORK [Code] [Code]
          deriving (Read, Show)
newtypeActionM m a = ActionM {runActionM :: a -> ma}instanceMonad m => Semigroup (ActionMma) whereActionM f <> ActionM g = ActionM (f >=> g)
instanceMonad m => Monoid (ActionMma) whereActionM f `mappend` ActionM g = ActionM (f >=> g)
  mempty = ActionM return
newtypeProgram m a = Program { getProgram :: ([Code], ActionMm (VMa)) }deriving (Semigroup, Monoid)
typeProgram' m a = (Code -> VMa -> m (VMa)) -> Program m aprogram c f p = Program . ([c],) . ActionM $
  \vm -> case status vm ofNothing -> p c =<< f (stack vm) vm
    m -> return vm
programM c f p = Program . ([c],) . ActionM $
  \vm -> case status vm ofNothing -> p c =<< f (memory vm, stack vm) vm
    m -> return vm
run :: Monad m => Program m a -> VM a -> m (VM a) 
run = runActionM . snd . getProgram
toCode :: Monad m => Program' m a -> [Code]
toCode prog = fst . getProgram $ prog none
none :: Monad m => Code -> VM a -> m (VM a)
none = const return
-- запуск программы вне монадexec :: Program'Identity () -> VM ()
exec = runIdentity . execM
execM :: Monad m => Program' m () -> m (VM ())
execM prog = run (prog none) (mkVM ())
execLog p prog = run (prog $ \c -> \vm -> return $ addRecord (p c vm) vm) (mkVM mempty)
f &&& g = \c -> \r -> (f c r, g c r)
logStack _ vm   = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _     = const (Sum1)
logCode c _   = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')
debug p = unlines . reverse . journal <$> execLog logRun p
------------------------------------------------------------pop,dup,swap,exch :: Monad m => Program' m a
put,get,push :: Monad m => Int -> Program' m a
add,mul,sub,frac,modulo,inc,dec,neg :: Monad m => Program' m a
eq,neq,lt,gt :: Monad m => Program' m a
err m = setStatus . Just $ "Error : " ++ m
pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."push x = program (PUSH x) $ \s -> setStack (x:s)
dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "expected two arguments."put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s <=< setMemory (m // [(i,x)])
          _ -> err "put expected an argument"get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)
indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"else f
app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
modulo = app2 MOD (flip mod)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then1else0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then1else0)
lt = app2 LTH (\x -> \y -> if (x > y) then1else0)
gt = app2 GTH (\x -> \y -> if (x < y) then1else0)
proceed p prog s = run (prog p) <=< setStack s
rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0then proceed p (stimes n body) s
                   else err "rep expected positive argument."
        go _ = err "rep expected an argument."branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = do res <- proceed p test (stack vm) vm
                   case (stack res) of0:s -> proceed p mempty s res
                     _:s -> go =<< proceed p body s res
                     _ -> err "while expected an argument." vm
ask :: Program'IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm
prt :: Program'IO a
prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"prtS :: String -> Program'IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm
fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) none
  where go = run (br1 p) <> run (br2 p)
------------------------------------------------------------fromCode :: Monad m => [Code] -> Program' m a
fromCode = hom
  where
    hom = foldMap $ \caseIF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      MOD -> modulo
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg
      _ -> mempty
fromCodeIO :: [Code] -> Program'IO a
fromCodeIO = hom
  where
    hom = foldMap $ \caseIF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      ASK -> ask
      PRT -> ask
      PRTS s -> prtS s
      c -> fromCode [c]
fromCodeList :: [Code] -> Program' [] a
fromCodeList = hom
  where
    hom = foldMap $ \caseIF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      FORK b1 b2 -> fork (hom b1) (hom b2)
      c -> fromCode [c]

Within this model of computation, two new commands can be defined: to read data from stdinor from the keyboard and to output a value or message to print.


ask, prt :: Program'IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm
prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"prtS :: String -> Program'IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm

Now you can write something interactive and make sure that we managed to combine calculations and effects:


ioprog = prtS "input first number" <> ask <>
         prtS "input second number" <> ask <>
         rep (prt <> dup <> inc) <>
         prt

λ> exec ioprog
 input first number
 3 
 input second number
 5345678VM {stack = [8,7,6,5,4,3], status = Nothing, memory = [0,0,0,0], journal = ()}

For the organization of ambiguous calculations, it is enough to define a combinator, a branching stream:


fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) pure
  where go = run (br1 p) <> run (br2 p)

Here , the monoid algebra worked again: the functions runreturn the converter VM -> m VM, their monoidal composition - the function that returns the composition of the converters, but now within the monad [], that is, the list of options.


The result of an extensive program will be a list of the final state of the machine:


λ> stack <$> exec (push 5 <> push 3 <> add `fork` sub)
[[8],[2]]
λ> stack <$> exec (push 5 <> push 3 `fork` dup <> push 2)
[[2,3,5],[2,5,5]]

Let's count an example from the beginning of the article: $ (2 \ pm 3) * ((4 \ pm 8) \ pm 5) $:


λ> let pm = add `fork` sub
λ> stack <$> exec (push 2 <> push 3 <> push 4 <> push 8 <> pm <> push 5 <> pm <> pm <> mul)
[[40],[-28],[20],[-8],[8],[4],[-12],[24]]

And here is a comparison of the effectiveness of four factorial implementations:


λ> journal <$> execLog logSteps (push 8 <> fact `fork` fact1 `fork` fact2 `fork` fact3)
[Sum {getSum = 48},Sum {getSum = 63},Sum {getSum = 34},Sum {getSum = 43}]

Writing an expression from the four branches of calculations without parentheses allowed us that the programs form a monoid with an operation fork, which means that the operation is forkassociative.


It's nice that all the basic teams and combinators coexist in the same module and stick together in the same type. Debugging works for all types of calculations. The only limitation is that in our implementation it is impossible to combine ambiguous calculations and input / output, however, and this is solved with the help of monad transformers.


$ * * * $


From the ancient Greek μάγμα translated as dirt or dough. Indeed, by gluing together pieces of dough, we will again get pieces of dough that can be glued together. This seems more than a trivial observation, but this is precisely the charm of clay or, for example, the Lego designer: thanks to the universal interface, the connection of two designer cubes creates a new cube, ready to connect with someone. With toys, sticky velcro, for example, it will not work.


Lego cubes allow making what could not even come to their creators, while many designers do not allow the expansion of the model - as the factory did, what program they sewed up, so be it. And no matter how you connect, you get only what is provided for by the construction or non-working trash. In terms of protection from the fool - it's great! But seriously, the essence and value of functional programming lies precisely in the richness and flexibility of the combination. Functions in combination can form new functions, which again can be combined in different ways. For decades, people do not cease to find new combinations (these are continuations and the notorious monads and lenses-professionalizers) with useful and sometimes amazing properties. But the most important thing is that this approach is not the prerogative of functional programming! In any paradigm, you can create hard "disposable" blocks, cumbersome frameworks that require the production of new and new blocks, because they are not combined arbitrarily, or create elegant expandable long-lived solutions. But it is in the functional paradigm that such solutions can be built sequentially, they can be proved and investigated mathematically, hone them before being packed into beautiful and opaque boxes and released into the world of technology.




All modules are available in the repository . Some figures reflecting the performance of the solution are added to the comments. The most important result - the use of a monoid in the Kleisley category opens up possibilities for a substantial increase in the speed of execution of programs running on a stack machine using memory. The principle of construction of the program does not change.


Also popular now: