Привет, Хабр! В рамках данной статьи мы создадим интерпретатор для простого языка программирования с использованием обобщённой свёртки. Далее следует небольшое введение. Для тех, кто уже знаком с типом 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 для преобразования всех значений в этом типе в одно. Рассмотрим плюсы данного подхода на примере интерпретации абстрактного синтаксического дерева (далее АСД):

1. Обработка синтаксического дерева без явного использования рекурсии позволяет избавиться от ошибок, связанных с тем, что мы забыли вызвать нашу функцию для одного из листов дерева. Например,  когда мы вызвали функцию в операторе If для условия и then блока, а для else забыли. Также это позволяет писать менее нагруженный код, так как явной рекурсии в коде больше не будет.

2. Возможность снабдить каждый лист дерева дополнительной информацией и гарантировать её наличие.  В нашем случае каждый лист дерева будет снабжён информацией о позиции внутри файла с программой, что  позволит нам печатать сообщения об ошибках вместе со строкой, на которой она произошла.

Приступим к разработке интерпретатора.

Синтаксис

Поддерживаются только переменные с типом 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.