Применение обобщённой свёртки для обработки синтаксических деревьев
Привет, Хабр! В рамках данной статьи мы создадим интерпретатор для простого языка программирования с использованием обобщённой свёртки. Далее следует небольшое введение. Для тех, кто уже знаком с типом Fix — фиксированной точкой для функторов, оставляю ссылку на основную часть статьи.
Правая свёртка для списков
Свёртка — операция, которая разрушает исходную структуру типа и возвращает одно значение. Например, преобразует список чисел в их сумму, при этом сама структура списка как бы разрушается. Рассмотрим правую свёртку для списка:
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr f ini (x:xs) = f x (foldr f ini xs)
foldr _ ini _ = iniКак можно заметить, функция f, которая передаётся первым аргументом, вызывается для каждого элемента списка, но при этом в ней не реализован рекурсивный обход списка. Получается, что в foldr реализуется обход списка и вызов нашей функции для каждого его элемента, нам же остаётся реализовать только непосредственно обработку. Возникает вопрос — можем ли мы написать функцию, аналогичную foldr, которая будет работать для любого рекурсивного типа данных. Ответ — да, можем. Как, расскажу в следующих разделах.
Тип Fix
В данном разделе мы рассмотрим структуру данных список и выделим на его примере общий для всех рекурсивных типов паттерн.
data List a = Nil | Elem a (List a)Давайте попробуем убрать рекурсию из данного типа, добавив параметр типа:
data List a b = Nil | Elem a bПопробуем теперь создать список с двумя элементами:
xs = Elem 1 (Elem 2 Nil)Прекрасно! У нас получилось — объявление типа списка теперь лишено рекурсии. Но есть одно, но — xs имеет тип не List Int, как это было прежде, а List Int (List Int (List Int a)). То есть теперь мы не можем создать функцию, которая работает со списком, имеющим произвольный размер. На помощь нам приходит тип с фиксированной точкой.
newtype Fix f = Fix { unFix :: f (Fix f) }Раньше вместо параметра b в типе List мы подставляли List a, теперь если мы передадим в качестве параметра List a в Fix, конструктор Fix сделает то же самое за нас:
type FixedList a = Fix (List a)Снова создадим список с двумя элементами:
xs :: FixedList Int
xs = Fix (Elem 1 (Fix (Elem 2 (Fix Nil))))Можно радоваться — мы и рекурсию из типа убрали и тип теперь одинаков для любого количества элементов в списке. Аналогичные преобразования можно применить к любому рекурсивному типу, просто заменив его вхождения на параметр типа.
Пишем свёртку для Fix
Мы можем использовать второй параметр типа List, который ввели, чтобы исключить рекурсию из определения, для хранения значения аккумулятора. Рассмотрим пример склейки в строку всех значений списка с двумя элементами. Далее будет приведён код на псевдохаскеле, в каждом примере мы будем обрабатывать следующую часть списка:
xs :: FixedList Int
xs = Fix (Elem 1 (Fix (Elem 2 (Fix Nil))))Первый шаг
Преобразуем Nil в начальное значение аккумулятора, то есть в пустую строку:
f :: List Int String -> String
f Nil = ""Второй шаг
Преобразуем второй элемент списка и значение аккумулятора в новое значение аккумулятора:
f :: List Int String -> String
f (Elem 2 acc) = "2" ++ accТретий шаг
Преобразуем первый элемент списка и значение аккумулятора в новое значение аккумулятора:
f :: List Int String -> String
f (Elem 1 acc) = "1" + accВ результате получаем »12». В данном примере f — функция обработки списка, которую мы будем передавать в нашу свёртку.
Когда идея того, как должна работать свёртка для типа Fix понятна, реализуем её.
foldFix :: Functor f => (f a -> a) -> Fix f -> a
foldFix f = f . fmap (foldFix f) . unFixТип должен быть функтором, чтобы мы могли проникать в его структуру и выполнять свёртку, начиная с конца. a в данном случае является типом аккумулятора. Значение аккумулятора всегда будет находится в тех местах, куда мы поместили параметр типа для избавления от рекурсии.
Пишем развёртку для Fix
При написании интерпретатора нам понадобится развёртка для типа Fix. Развёртка позволяет сгенерировать рекурсивный тип данных из одного начального:
unfoldFix :: Functor f => (a -> f a) -> a -> Fix f
unfoldFix f = Fix . fmap (unfoldFix f) . fПолный пример со списком:
{-# LANGUAGE DeriveFunctor #-}
module Main (main) where
import Prelude hiding (showList)
newtype Fix f = Fix { unFix :: f (Fix f) }
foldFix :: Functor f => (f a -> a) -> Fix f -> a
foldFix f = f . fmap (foldFix f) . unFix
unfoldFix :: Functor f => (a -> f a) -> a -> Fix f
unfoldFix f = Fix . fmap (unfoldFix f) . f
type List a = Fix (ListF a)
data ListF a b = Nil | Elem a b deriving Functor
showList :: Show a => List a -> String
showList = foldFix showListF
showListF :: Show a => ListF a String -> String
showListF Nil = ""
showListF (Elem x acc) = show x ++ acc
-- Список чисел от 0 до 3
list :: List Int
list = unfoldFix (\x -> if x <= 3 then Elem x (x + 1) else Nil) 0
-- Выведет в консоль 0123
main :: IO ()
main = putStrLn $ showList listСтоит отметить, что в дальнейшем мы не будем использовать самописный тип Fix, так как он уже реализован в пакете data-fix.
Создаём интерпретатор
Итак, мы можем избавить определение любого рекурсивного типа данных от рекурсии и использовать функцию foldFix для преобразования всех значений в этом типе в одно. Рассмотрим плюсы данного подхода на примере интерпретации абстрактного синтаксического дерева (далее АСД):
Обработка синтаксического дерева без явного использования рекурсии позволяет избавиться от ошибок, связанных с тем, что мы забыли вызвать нашу функцию для одного из листов дерева. Например, когда мы вызвали функцию в операторе
Ifдля условия иthenблока, а дляelseзабыли. Также это позволяет писать менее нагруженный код, так как явной рекурсии в коде больше не будет.Возможность снабдить каждый лист дерева дополнительной информацией и гарантировать её наличие. В нашем случае каждый лист дерева будет снабжён информацией о позиции внутри файла с программой, что позволит нам печатать сообщения об ошибках вместе со строкой, на которой она произошла.
Приступим к разработке интерпретатора.
Синтаксис
Поддерживаются только переменные с типом int и bool, условный оператор if, цикл while и рекурсивные функции. Пример программы приведён ниже:
def fac_rec(x) {
if x == 2 {
return x
} else {
return x * fac_rec(x - 1)
}
}
def fac_iter(x) {
res = 1
while x >= 2 {
res = x * res
x = x - 1
}
return res
}
def main() {
while true {
print("Enter mode:\n1) recursive\n2) iterative\n3) exit\n")
mode = read()
if mode == 1 || mode == 2 {
print("Enter x: ")
x = read()
res = 0
if mode == 1 {
res = fac_rec(x)
} else {
res = fac_iter(x)
}
print("x!: ", res, "\n")
} else {
if mode == 3 {
break
} else {
print("mode is invalid\n")
}
}
}
}АСД
Напишем рекурсивный тип для представления АСД:
data Function = Function
{ funName :: Text
, funArgs :: [Text]
, funBody :: Expr
} deriving Eq
data Expr
= IntLit Int
| BoolLit Bool
| Var Text
| UnOp UnOp Expr
| BinOp BinOp Expr Expr
| Assign Text Expr
| If Expr Expr (Maybe Expr)
| While Expr Expr
| Seq [Expr]
| Call Text [Expr]
| Break
| Read
| Print [PrintArg]
| Return (Maybe Expr)
deriving Eq
data UnOp = Neg | Not deriving Eq
data BinOp
= Add | Sub | Mul | Div
| Lt | Le | Gt | Ge
| Eq | Ne | And | Or
deriving Eq
data PrintArg
= StrArg Text
| ExprArg Expr
deriving EqЗатем уберём рекурсию из определения типов:
module Lang.Ast.Types where
data Function b = Function
{ funName :: Text
, funArgs :: [Text]
, funBody :: b
} deriving (Eq, Functor, Foldable, Traversable)
type Expr = Fix ExprF
data ExprF a
= IntLit Int
| BoolLit Bool
| Var Text
| UnOp UnOp a
| BinOp BinOp a a
| Assign Text a
| If a a (Maybe a)
| While a a
| Seq [a]
| Call Text [a]
| Break
| Read
| Print [PrintArg a]
| Return (Maybe a)
deriving (Functor, Foldable, Traversable)
data UnOp = Neg | Not deriving Eq
data BinOp
= Add | Sub | Mul | Div
| Lt | Le | Gt | Ge
| Eq | Ne | And | Or
deriving Eq
data PrintArg a
= StrArg Text
| ExprArg a
deriving (Functor, Foldable, Traversable)Снабжаем каждый лист АСД позицией в файле
module Lang.Ast.Annotated where
-- Выражение, снабжённое позицией
type PosExpr = Fix PosExprF
type PosExprF = AnnF SourceSpan ExprF
-- Композиция функтора f с функтором аннотации
type AnnF ann f = Compose (Ann ann) f
-- Функтор, который содержит объект и его аннотацию
data Ann ann a = Ann
{ annotation :: ann
, annotated :: a
} deriving (Functor, Foldable, Traversable)
-- Начало и конец выражения в файле
data SourceSpan = SourceSpan
{ spanBegin :: SourcePos
, spanEnd :: SourcePos
} deriving (Eq, Show)
instance Semigroup SourceSpan where
s1 <> s2 = SourceSpan ((min on spanBegin) s1 s2) ((max on spanEnd) s1 s2)
-- Позиция в файле
data SourcePos = SourcePos
{ posFile :: FilePath
, posLine :: Int
, posColumn :: Int
} deriving (Eq, Show)
instance Ord SourcePos where
compare (SourcePos _ b1 e1) (SourcePos _ b2 e2) = compare b1 b2
<> compare e1 e2
-- Функция для удаления всех аннотаций из синтаксического дерева
stripAnnotation :: Functor f => Fix (AnnF ann f) -> Fix f
stripAnnotation = unfoldFix (annotated . getCompose . unFix)Инстанс Eq
Нам может понадобится сравнивать выражения. Для типа Fix f определён инстанс класса Eq, если для f определён инстанс класса Eq1. Напишем определения Eq1 для типов ExprF, PrintArg и Ann.
import Data.Functor.Classes (Eq1(..))
instance Eq1 ExprF where
liftEq f a b = case (a, b) of
(IntLit i1, IntLit i2) -> i1 == i2
(BoolLit b1, BoolLit b2) -> b1 == b2
(Var v1, Var v2) -> v1 == v2
(UnOp op1 e1, UnOp op2 e2) -> op1 == op2
&& f e1 e2
(BinOp op1 e11 e12, BinOp op2 e21 e22) -> op1 == op2
&& f e11 e21
&& f e12 e22
(Assign v1 e1, Assign v2 e2) -> v1 == v2 && f e1 e2
(If cnd1 th1 el1, If cnd2 th2 el2) -> f cnd1 cnd2
&& f th1 th2
&& liftEq f el1 el2
(While cnd1 body1, While cnd2 body2) -> f cnd1 cnd2 && f body1 body2
(Seq ss1, Seq ss2) -> liftEq f ss1 ss2
(Call fn1 args1, Call fn2 args2) -> fn1 == fn2
&& liftEq f args1 args2
(Break, Break) -> True
(Read, Read) -> True
(Print args1, Print args2) -> liftEq (liftEq f) args1 args2
(Return v1, Return v2) -> liftEq f v1 v2
_ -> False
instance Eq1 PrintArg where
liftEq f a b = case (a, b) of
(StrArg s1, StrArg s2) -> s1 == s2
(ExprArg e1, ExprArg e2) -> f e1 e2
_ -> False
instance Eq ann => Eq1 (Ann ann) where
liftEq f (Ann a1 g1) (Ann a2 g2) = a1 == a2 && f g1 g2Парсер
Про аппликативные парсеры есть куча хороших статей, поэтому я не буду останавливаться на полной реализации парсера, её можно посмотреть в репозитории. Здесь для примера того, как снабжать выражения позицией в файле, приведу код парсера для целочисленных констант:
import Data.Fix (Fix(..))
import Data.Functor.Compose (Compose(..))
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec hiding (SourcePos(..))
import Lang.Ast.Annotated
import Lang.Ast.Types
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char.Lexer as Lexer
type Parser = Parsec Void Text
pIntLit :: Parser PosExpr
pIntLit = annotate (IntLit <$> Lexer.decimal)
annotate :: Parser (f (Fix (AnnF SourceSpan f)))
-> Parser (Fix (AnnF SourceSpan f))
annotate p = do
from <- convertPos <> getSourcePos
let ann = SourceSpan from to
pure $ Fix (Compose $ Ann ann res)
where convertPos :: Megaparsec.SourcePos -> SourcePos
convertPos (Megaparsec.SourcePos path from to) =
SourcePos path (Megaparsec.unPos from) (Megaparsec.unPos to)Интерпретатор
Для начала создадим монады, в которые будем интерпретировать программы. В одну монаду будут интерпретироваться выражения, снабжённые позицией, а в другую — не снабжённые. Это нужно, чтобы написать полиморфную функцию вывода ошибок. В одном случае она будет показывать строку с ошибкой, в другом — нет:
-- В эту монаду будут интерпретироваться выражения, снабжённые позицией
newtype PosInterpreterM a = PosInterpreterM
{ runPosInterpreterM :: ReaderT (Context PosInterpreterM) IO a
} deriving ( Functor
, Applicative
, Monad
, MonadReader (Context PosInterpreterM)
, MonadIO
)
-- В эту монаду будут интерпретироваться выражения, не снабжённые позицией
newtype InterpreterM a = InterpreterM
{ runInterpreterM :: ReaderT (Context InterpreterM) IO a
} deriving ( Functor
, Applicative
, Monad
, MonadReader (Context InterpreterM)
, MonadIO
)
data Context m = Context
{ ctxVariables :: IORef (HashMap Text Value) -- Значения переменных в текущей функции
, ctxFunctions :: HashMap Text (FuncInfo m) -- Функции
, ctxSourceSpan :: SourceSpan -- Позиция в файле для текущего выражения
, ctxSourceCode :: Text -- Код программы
, ctxIsBreak :: IORef Bool -- Нужно ли выйти из цикла
, ctxIsReturn :: IORef Bool -- Нужно ли выйти из функции
, ctxReturnValue :: IORef (Maybe Value) -- Значение, которое вернула текущая функция
}
data FuncInfo m = FuncInfo
{ infArgs :: ![Text] -- Список аргументов функции
, infBody :: !(m (Maybe Value)) -- Тело функции
}
data Value
= IntValue Int
| BoolValue Bool
deriving EqНам также понадобится класс типов для полиморфной функции возврата ошибки:
class Monad m => MonadError m where
throwError :: Text -> m aНапишем инстансы для наших монад:
instance MonadError PosInterpreterM where
throwError err = do
SourcePos fpath ln cl <- asks (spanBegin . ctxSourceSpan)
src <- asks ctxSourceCode
let strLn = Text.pack $ show ln
margin = Text.replicate (Text.length strLn + 2) " "
errMsg = Text.pack fpath <> ":" <> strLn <> ":"
<> Text.pack (show cl)
<> ": error:\n" <> err <> "\n"
line = Text.takeWhile (/='\n')
. (!!(ln-1))
. iterate (Text.tail . Text.dropWhile (/= '\n')) $ src
prettyLine = margin <> "|\n " <> strLn <> " | " <> line <> "\n"
<> margin <> "|\n"
liftIO $ throwIO $ InterpreterException (errMsg <> prettyLine)
instance MonadError InterpreterM where
throwError = liftIO . throwIO . InterpreterException
data InterpreterException = InterpreterException Text
instance Show InterpreterException where
show (InterpreterException err) = "InterpreterException: "
++ Text.unpack err
instance Exception InterpreterException whereДля PosInterpreterM ошибка будет выглядеть следующим образом:
InterpreterException: example.lang:19:12:
|
19 | while 1 {
|
1 is not a boolean valueА для InterpreterM следующим:
InterpreterException: 1 is not a boolean valueДалее напишем интерпретатор для выражений без позиции. Каждое выражение возвращает либо Int, либо Bool, либо ничего, поэтому тип возвращаемого значения m (Maybe Value):
interpretExpr :: (MonadReader (Context m) m, MonadError m, MonadInput m)
=> Expr
-> m (Maybe Value)
interpretExpr = foldFix interpretExprF
-- Пока оставим заглушку
interpretExprF :: (MonadReader (Context m) m, MonadError m, MonadInput m)
=> ExprF (m (Maybe Value))
-> m (Maybe Value)
interpretExprF = undefinedСамое интересное начинается сейчас — мы напишем интерпретатор для выражений с позицией, используя ту же функцию interpretExprF, что и для выражений без позиции. При этом перед вызовом interpretExprF для каждого листа синтаксического дерева, мы будем класть в контекст позицию этого листа в коде и затем убирать её из листа. Если бы мы использовали для представления синтаксического дерева обычный рекурсивный тип данных, нам пришлось бы явно класть в каждый лист позицию в коде:
-- Обработка дерева, явно содержащего позицию
interpretExpr (IntLit x pos) = ...
-- Обработка дерева, неявно содержащего позицию
interpretExprF (IntLit x) = ...Для этого нам потребуется вспомогательная функция:
adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi f g = g (f . fmap (adi f g) . unFix)Я позаимствовал её из проекта hnix. Основная идея заключается в том, что перед вычислением свёртки мы вызываем функцию g, которая позволяет сделать что-нибудь с текущим листом, например, модифицировать или извлечь информацию. В нашем случае мы будем доставать из листа позицию, класть её в контекст и после вызывать вычисление свёртки. Делать мы это будем в функции setContext:
setContext :: (PosExpr -> InterpeterM (Maybe Value))
-> PosExpr
-> InterpeterM (Maybe Value)
setContext f expr = local (\ctx -> ctx { ctxSourceSpan = sourceSpan }) $
f expr
where sourceSpan = annotation $ getCompose $ unFix exprСоберём всё вместе и получим интерпретатор для выражений, снабжённых позицией:
interpretPosExpr :: PosExpr -> PosInterpreterM (Maybe Value)
interpretPosExpr = adi (interpretExprF . annotated . getCompose) setContextТеперь реализуем функцию interpretExprF. Сначала нужно будет реализовать функцию shouldSkip, которая будет вычислять выражение только в том случае, если переменные контекста ctxIsBreak и ctxIsReturn не установлены. Это нужно, чтобы инструкции после Break и Return не исполнялись:
shouldSkip :: (MonadReader (Context m) m, MonadIO m)
=> m (Maybe a)
-> m (Maybe a)
shouldSkip ma = do
brk <- asks ctxIsBreak >>= liftIO . readIORef
ret <- asks ctxIsReturn >>= liftIO . readIORef
if brk || ret then pure Nothing else maНаписание интерпретатора начнём с числовых и булевых выражений. Мы просто преобразуем их в тип Value с помощью конструкторов IntValue и BoolValue соответственно:
interpretExprF :: (MonadReader (Context m) m, MonadError m, MonadIO m)
=> ExprF (m (Maybe Value))
-> m (Maybe Value)
interpretExprF = shouldSkip . \case
IntLit i -> pure $ Just $ IntValue i
BoolLit b -> pure $ Just $ BoolValue bДалее переходим к переменным. Если удалось найти значение по имени переменной в хэш-таблице ctxVariables, то возвращаем его, иначе кидаем исключение:
Var x ->
variablesRef <- asks ctxVariables
mValue <- HashMap.lookup v <$> liftIO (readIORef variablesRef)
case mValue of
Nothing -> throwError $ "undefined variable " <> v
Just value -> pure $ Just valueДалее будем интерпретировать унарные и бинарные операции. Для этого нам понадобятся три вспомогательные функции:
-- Функция возвращает значение типа Int, полученное из результата вычисления,
-- или ошибку
intValue :: MonadError m => m (Maybe Value) -> m Int
intValue mVal = mVal >>= \case
Just (IntValue val) -> pure val
Just BoolValue{} -> typeError "int" "bool"
Nothing -> typeError "int" "unit"
-- Функция возвращает значение типа Bool, полученное из результата вычисления,
-- или ошибку
boolValue :: MonadError m => m (Maybe Value) -> m Bool
boolValue mVal = mVal >>= \case
Just (BoolValue val) -> pure val
Just IntValue{} -> typeError "bool" "int"
Nothing -> typeError "bool" "unit"
-- Функция возвращает ошибку типизации
typeError :: MonadError m => Text -> Text -> m a
typeError expected actual = throwError $ "type error: expected "
<> expected
<> " actual "
<> actualПриступим к самим операциям. Я привёл код только трёх бинарных операций, потому что остальные реализуются похожим образом и не требуют детального описания:
UnOp op mVal -> case op of
Neg -> Just . IntValue . negate <$> intValue mVal
Not -> Just . BoolValue . not <$> boolValue mVal
BinOp op mVal1 mVal2 -> case op of
Add -> Just . IntValue <$> ((+) <$> intValue mVal1 <*> intValue mVal2)
Eq -> Just . BoolValue <$> ((==) <$> mVal1 <*> mVal2)
And -> do
val1 <- boolValue mVal1
if val1
then Just . BoolValue <$> boolValue mVal2
else pure $ Just $ BoolValue FalseДалее по списку идёт операция присваивания. Для неё нужно написать ещё одну вспомогательную функцию:
anyValue :: MonadError m => m (Maybe a) -> m a
anyValue mVal = mVal >>= maybe (typeError "int or bool" "unit") pureКод для самого присваивания приведён ниже:
Assign var mVal -> do
val <- anyValue mVal
variablesRef <- asks ctxVariables
liftIO $ modifyIORef variablesRef (HashMap.insert var val)
pure NothingТеперь напишем реализацию условных выражений:
If mCnd th el -> do
cnd <- boolValue mCnd
if cnd then th else fromMaybe (pure Nothing) elЗатем реализуем операции Break и Return:
-- Устанавливаем ctxIsBreak
Break -> do
brkRef <- asks ctxIsBreak
liftIO $ writeIORef brkRef True
pure Nothing
-- Устанавливаем ctxIsReturn, вычисляем возвращаемое значение
-- и кладём его в ctxReturnValue
Return mVal -> do
val <- fromMaybe (pure Nothing) mVal
returnValue <- asks ctxReturnValue
isReturn <- asks ctxIsReturn
liftIO $ do
writeIORef returnValue val
writeIORef isReturn True
pure NothingДля цикла while нам понадобятся следующие функции:
-- Выполняет тело цикла, пока условие не вернёт False
while :: Monad m => m Bool -> m a -> m ()
while mCond mbody = do
cond <- mCond
when cond (mbody >> while mCond mbody)
-- Если в цикле была исполнена одна из операций break или return,
-- то будет установлена одна из переменных ctxIsBreak или ctxIsReturn.
-- Поэтому перед вычислением условия, мы проверяем эти переменные.
-- Если одна из них установлена, возвращаем False, иначе возвращаем
-- результат условия. Перед выходом из цикла, сбрасываем ctxIsBreak.
whileCond :: (MonadReader (Context m) m, MonadError m, MonadIO m)
=> m (Maybe Value)
-> m Bool
whileCond mCond = do
brkRef <- asks ctxIsBreak
brk <- liftIO $ readIORef brkRef
ret <- asks ctxIsReturn >>= liftIO . readIORef
if brk || ret
then liftIO (writeIORef brkRef False) >> pure False
else boolValue mCondРеализация цикла while выглядит следующим образом:
While mCond mBody -> while (whileCond mCond) mBody >> pure NothingДалее реализуем операцию Seq — последовательное исполнение команд.
Seq ss -> sequence_ ss >> pure NothingСледующий шаг — вызов функции. Напишем очередную вспомогательную функцию:
callFunction :: (MonadReader (Context m) m, MonadError m, MonadIO m)
=> Text
-> [Value]
-> m (Maybe Value)
callFunction fun args = do
-- Находим тело функции по имени, если не находим, кидаем исключение.
funcs <- asks ctxFunctions
case HashMap.lookup fun funcs of
Nothing -> throwError $ "undefined function " <> fun
Just fInfo -> call fInfo
where call (FuncInfo argNames body)
-- Если количество переданных аргументов не равно количеству
-- ожидаемых, кидаем исключение
| actualNumArgs /= expectedNumArgs
= throwError $ "function " <> fun <> " expected "
<> Text.pack (show expectedNumArgs)
<> " arguments but given "
<> Text.pack (show actualNumArgs)
| otherwise = do
-- Запоминаем значения переменных для текущей функции
-- и пишем в ctxVariables значения аргументов для
-- вызываемой функции
let argsMap = HashMap.fromList $ zip argNames args
variablesRef <- asks ctxVariables
backupVars <- liftIO $ readIORef variablesRef
liftIO $ writeIORef variablesRef argsMap
-- Вызываем тело функции
void body
-- Восстанаваливаем значения переменных текущей функции.
-- Сбрасываем ctxIsReturn, достаём возвращаемой значение
-- из ctxReturnValue и возвращаем его
liftIO $ writeIORef variablesRef backupVars
returnValueRef <- asks ctxReturnValue
isReturnRef <- asks ctxIsReturn
returnValue <- liftIO $ readIORef returnValueRef
liftIO $ do
writeIORef returnValueRef Nothing
writeIORef isReturnRef False
pure returnValue
where actualNumArgs = length args
expectedNumArgs = length argNamesРеализации вызова функции приведена ниже:
Call fun mArgs -> do
args <- anyValue (sequence <$> sequence mArgs)
callFunction fun argsОстаётся реализовать только ввод-вывод:
Read -> do
str <- liftIO Text.getLine
case Text.signed Text.decimal str of
Right (res, _) -> pure $ Just $ IntValue res
Left{}
| str == "true" -> pure $ Just $ BoolValue True
| str == "false" -> pure $ Just $ BoolValue False
| otherwise -> liftIO $ throwIO $
InterpreterException "failed to read value"
Print args -> do
forM_ args $ \case
StrArg str -> liftIO $ Text.putStr str
ExprArg mVal -> mVal >>= \case
Just (IntValue i) -> liftIO $ putStr $ show i
Just (BoolValue b) -> liftIO $ Text.putStr $ if b
then "true"
else "false"
Nothing -> typeError "int or bool" "unit"
pure NothingИнтерпретатор для выражений мы написали, однако программа состоит из функций, поэтому нужно написать интерпретатор для списка функций. Таких интерпретаторов будет два — один для функций, выражения в которых снабжены позицией, второй — для тех, в которых не снабжены:
interpretFunctions :: Text -> [Function Expr] -> IO ()
interpretFunctions = genericInterpretFunctions interpretExpr toIO
where toIO ctx ma = runReaderT (runInterpreterM ma) ctx
interpretPosFunctions :: Text -> [Function PosExpr] -> IO ()
interpretPosFunctions = genericInterpretFunctions interpretPosExpr toIO
where toIO ctx ma = runReaderT (runPosInterpreterM ma) ctx
genericInterpretFunctions :: (MonadReader (Context m) m, MonadError m, MonadIO m)
=> (e -> m (Maybe Value))
-> (Context m -> m (Maybe Value) -> IO (Maybe Value))
-> Text
-> [Function e]
-> IO ()
genericInterpretFunctions eval toIO sourceCode funDefs = do
variables <- newIORef HashMap.empty
isBreak <- newIORef False
isReturn <- newIORef False
retValue <- newIORef Nothing
let ctx = Context
{ ctxVariables = variables
, ctxFunctions = functions
, ctxSourceSpan = SourceSpan initPos initPos
, ctxSourceCode = sourceCode
, ctxIsBreak = isBreak
, ctxIsReturn = isReturn
, ctxReturnValue = retValue
}
void $ toIO ctx (callFunction "main" [])
where initPos = SourcePos "" 1 1
functions = foldl collectFunction HashMap.empty funDefs
collectFunction funcs (Function name args body) =
HashMap.insert name func funcs
where func = FuncInfo args (eval body)Собираем всё вместе
Все части интерпретатора написаны, осталось соединить их вместе:
module Main (main) where
import System.Environment (getArgs, getProgName)
import System.Exit (die)
import Lang.Ast (interpretPosFunctions)
import Lang.Parser (parseFromText)
import qualified Data.Text.IO as Text
main :: IO ()
main = do
fileName <- getFileName
sourceCode <- Text.readFile fileName
case parseFromText fileName sourceCode of
Left err -> Text.putStrLn err
Right fs -> interpretPosFunctions sourceCode fs
where getFileName = getArgs >>= \case
[x] -> pure x
_ -> do
progName <- getProgName
die $ "Usage: " ++ progName ++ " " Итоговый код интерпретатора можно посмотреть в репозитории.
Заключение
Интерпретаторы императивных языков не самым лучшим образом реализуются посредством свёртки. Для корректной работы операций break и return пришлось применять хак с установкой флагов ctxIsBreak и ctxIsReturn и их проверкой перед исполнением каждой операции. Для раскрытия темы я выбрал интерпретатор императивного, как более наглядный и простой пример. В качестве более красивого применения описанного подхода, могу привести проверку типов, реализованную мной для двух языков: harakiri и tiger, трансляцию синтаксического дерева языка harakiri в промежуточное представление и проект hnix, в котором реализуется интерпретатор для функционального языка программирования nix.
