Привет, Хабр! В рамках данной статьи мы создадим интерпретатор для простого языка программирования с использованием обобщённой свёртки. Далее следует небольшое введение. Для тех, кто уже знаком с типом 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 ++ " <file.lang>"Итоговый код интерпретатора можно посмотреть в репозитории.
Заключение
Интерпретаторы императивных языков не самым лучшим образом реализуются посредством свёртки. Для корректной работы операций break и return пришлось применять хак с установкой флагов ctxIsBreak и ctxIsReturn и их проверкой перед исполнением каждой операции. Для раскрытия темы я выбрал интерпретатор императивного, как более наглядный и простой пример. В качестве более красивого применения описанного подхода, могу привести проверку типов, реализованную мной для двух языков: harakiri и tiger, трансляцию синтаксического дерева языка harakiri в промежуточное представление и проект hnix, в котором реализуется интерпретатор для функционального языка программирования nix.
ссылка на оригинал статьи https://habr.com/ru/post/667058/
Добавить комментарий