Abstrakcja i dopasowanie do wzorców w Haskellu
Po hermetyzacji i abstrakcji RAMu dla interpretera HelMA pora na stos. Stos, zwłaszcza stos arytmetyczny, jest strukturą używaną w wielu interpreterach jezyków ezoterycznych. Więc warto wydzielić tą abstrakcję do osobnego modułu.
Żeby zaimplementować stos będziemy potrzebować dopasowania do wzorców (ang. pattern matching), niestety abstrakcje i dopasowanie do wzorców są to pojęcia kłócące się.
Ponieważ dopasowanie do wzorców działa na implementacji, Trzeba opakować dopasowanie do wzorców w abstrakcje.
Abstrakcja i klasy typów
Spójrzmy na moduł HelVM.HelCam.Common.Memories.Stack, dla czytelności podzielony na pięć listingów.
Najpierw deklaracje i importy:
{-# Language AllowAmbiguousTypes #-}
{-# Language FlexibleInstances #-}
{-# Language MultiParamTypeClasses #-}
module HelVM.HelCam.Common.Memories.Stack (
Index,
Stack,
select,
HelVM.HelCam.Common.Memories.Stack.empty,
HelVM.HelCam.Common.Memories.Stack.lookup,
HelVM.HelCam.Common.Memories.Stack.splitAt',
HelVM.HelCam.Common.Memories.Stack.drop',
push1,
pop1,
push2,
pop2
) where
import Data.Sequence as Seq
type Index = Int
Jak się później okaże, eksporty zawierają jeden typ, jedną klasę typów (ang. Type Class) i 9 funkcji, w tym jedna funkcja generyczna i osiem metod (uparcie nazywam tak funkcje w klasach typów).
Następnie kod, który normalnie znalazłby się w klasie bazowej:
select :: Stack s m => Index -> m -> s
select i stack = check $ HelVM.HelCam.Common.Memories.Stack.lookup i stack where
check (Just symbol) = symbol
check Nothing = error $ "Empty stack " <> show stack <> " index " <> show i
Definiujemy jedną funkcję generyczną. Czemu tylko jedną? O tym później.
Abstrakcja oparta na klasie typu
Nasz stos będzie potrzebować 8 podstawowych metod.
Podobnie jak dla klasy typów RAM potrzebujemy klasy typów dla dwóch parametrów, symbolu s i pamieci m:
class (Semigroup m, Show m) => Stack s m where
empty :: m
lookup :: Index -> m -> Maybe s
splitAt' :: s -> Index -> m -> (m, m)
drop' :: s -> Index -> m -> m
push1 :: s -> m -> m
pop1 :: m -> (s, m)
push2 :: s -> s -> m -> m
pop2 :: m -> (s, s, m)
Są tu dwie brzydkie metody splitAt' i drop'. Wynika to z tego, że w każdej sygnaturze muszą być użyte oba parametry generyczne. Niestety nie umiałem tego napisać lepiej.
Implementacja oparta na liście
Najpierw prostsza implementacja dla listy:
instance Show s => Stack s [s] where
empty = []
lookup i stack = stack !!? i
splitAt' _ i stack = Prelude.splitAt i stack
drop' _ i stack = Prelude.drop i stack
push1 symbol stack = symbol: stack
pop1 (symbol : stack) = (symbol, stack)
pop1 stack = error $ "Empty stack " <> show stack
push2 symbol symbol' stack = symbol: symbol': stack
pop2 (symbol : symbol' : stack) = (symbol, symbol', stack)
pop2 stack = error $ "Empty stack " <> show stack
Mamy tu klasyczne dopasowanie do wzorców dla list. Nic nadzwyczajnego.
Implementacja oparta na sekwencji
Implementacja dla sekwencji:
instance Show s => Stack s (Seq s) where
empty = Seq.fromList []
lookup i stack = Seq.lookup i stack
splitAt' _ i stack = Seq.splitAt i stack
drop' _ i stack = Seq.drop i stack
push1 symbol stack = symbol <| stack
pop1 (symbol :<| stack) = (symbol, stack)
pop1 stack = error $ "Empty stack " <> show stack
push2 symbol symbol' stack = symbol <| symbol' <| stack
pop2 (symbol :<| symbol' :<| stack) = (symbol, symbol', stack)
pop2 stack = error $ "Empty stack " <> show stack
Mamy tu dwa nowe operatory :<| dla dopasowania do wzorców oraz <| dla dołączania do sekwencji. Jeśli operowalibyśmy na drugim końcu sekwencji należałoby użyć :|> i |>.
Ograniczenia
Tutaj pojawia się mały zgrzyt. Niestety nie potrafię zdefinioć niektórych funkcji generycznych dla parametru generycznego Stack s m. Na razie musimy zadowolić się mniej genrycznymi wersjami dla parametru Stack Symbol m. Funkcje te są zdefiniowane w modułach HelVM.HelCam.Machines.ETA.StackOfSymbols oraz HelVM.HelCam.Machines.WhiteSpace.StackOfSymbols.
Funkcje pomocnicze dla interpretera eso języka ETA:
{-# Language FlexibleContexts #-}
module HelVM.HelCam.Machines.ETA.StackOfSymbols where
import HelVM.HelCam.Machines.ETA.EvaluatorUtil
import HelVM.HelCam.Common.Memories.Stack
-- Arithmetic
divMod :: Stack Symbol m => m -> m
divMod stack = push2 (symbol' `mod` symbol ::Symbol) (symbol' `div` symbol ::Symbol) stack'
where (symbol, symbol', stack') = pop2 stack
sub :: Stack Symbol m => m -> m
sub stack = push1 (symbol' - symbol ::Symbol) stack'
where (symbol, symbol', stack') = pop2 stack
-- Stack instructions
halibut :: Stack Symbol m => m -> m
halibut stack
| i <= 0 = copy (negate i) stack'
| otherwise = move (0 ::Symbol) i stack'
where (i, stack') = pop1 stack
move :: Stack Symbol m => Symbol -> Index -> m -> m
move symbol i stack = tops <> middles <> bottoms where
(middles, stack') = splitAt' symbol i stack
(tops, bottoms) = splitAt' symbol 1 stack'
copy :: Stack Symbol m => Index -> m -> m
copy i stack = push1 (select i stack ::Symbol) stack
Funkcje pomocnicze dla interpretera eso języka WhiteSpace:
{-# Language AllowAmbiguousTypes #-}
{-# Language FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# Language MultiParamTypeClasses #-}
module HelVM.HelCam.Machines.WhiteSpace.StackOfSymbols where
import HelVM.HelCam.Machines.WhiteSpace.EvaluatorUtil
import HelVM.HelCam.Machines.WhiteSpace.Instruction
import HelVM.HelCam.Common.Memories.Stack
-- Arithmetic
binaryOp :: Stack Symbol m => BinaryOperator -> m -> m
binaryOp op stack = push1 (doBinary op symbol symbol' ::Symbol) stack' where (symbol, symbol', stack') = pop2 stack
-- Stack instructions
swap :: Stack Symbol m => m -> m
swap stack = push2 (symbol'::Symbol) symbol stack' where (symbol, symbol', stack') = pop2 stack
discard :: Stack Symbol m => m -> m
discard = drop' (0::Symbol) 1
slide :: Stack Symbol m => Index -> m -> m
slide i stack = push1 (symbol::Symbol) (drop' (0::Symbol) i stack') where (symbol, stack') = pop1 stack
dup :: Stack Symbol m => m -> m
dup = copy 0
copy :: Stack Symbol m => Index -> m -> m
copy i stack = push1 (select i stack ::Symbol) stack
Jak widać funkcja copy :: Stack Symbol m => Index -> m -> m jest w obu modułach, jednak nie potrafię jej w prosty sposób uogólnić.
Przykład użycia
Jako przykład użycia fragment modułu HelVM.HelCam.Machines.ETA.Evaluator:
class Evaluator r where
next :: Stack Symbol m => InstructionUnit -> m -> r
next iu s = doInstruction t iu' s where (t, iu') = nextIU iu
doInstruction :: Stack Symbol m => Maybe Token -> InstructionUnit -> m -> r
-- IO instructions
doInstruction (Just O) iu s = doOutputChar iu s
doInstruction (Just I) iu s = doInputChar iu s
-- Stack instructions
doInstruction (Just N) iu s = next iu' (push1 (symbol::Symbol) s) where (symbol, iu') = parseNumber iu
doInstruction (Just H) iu s = next iu $ halibut s
-- Arithmetic
doInstruction (Just S) iu s = next iu $ sub s
doInstruction (Just E) iu s = next iu $ Stack.divMod s
-- Control
doInstruction (Just R) iu s = next iu s
doInstruction (Just A) iu@(IU il ic) s = next iu (push1 (nextLabel il ic) s)
doInstruction (Just T) iu@(IU il _ ) s = transfer $ pop2 s where
transfer (_, 0, s') = next iu s'
transfer (0, _, _ ) = doEnd
transfer (l, _, s') = next (IU il $ findAddress il l) s'
doInstruction Nothing _ _ = doEnd
----
doEnd :: r
doOutputChar :: Stack Symbol m => InstructionUnit -> m -> r
doInputChar :: Stack Symbol m => InstructionUnit -> m -> r
Cel został osiągnięty. Struktura stosu została schowana za abstrakcją klasy typu Stack. Teraz można swobodnie wymieniać implementację między listą a sekwencją.
Podsumowanie
Mimo że cel został osiągnięty, kod jednak nie wyszedł tak dobry jak chciałem. Może to pora na użycie Rodzin typów?
Kod interpretera HelMA po zmianach znajduje się na githubie.