Схемы рекурсии для бифункторов

Теги: haskell

Эта заметка о схемах рекурсии для бифункоторов. Тем, кто не знаком со схемами рекурсии, рекомендую для начала прочитать цикл статей в блоге sumtypeofway.

Для примера напишем простой интерпретатор для следующего языка:

data Stmt
    = Assign String Expr
    | Print Expr
    | Expr Expr
    | Seq (NonEmpty Stmt)

data Expr
    = Var String
    | Val Int
    | Binop Binop Expr Expr
    | If Relop Expr Expr Expr (Maybe Expr)
    | ESeq Stmt Expr

data Binop = Add | Sub | Mul | Div

data Relop = Eq | Ne | Lt | Le | Gt | Ge

Так как у нас два взаимнорекурсивных типа, мы не можем использовать уже знакомый тип Fix:

newtype Fix f = Fix { unFix :: f (Fix f) }

Поэтому напишем тип Fix2 для такого случая, а также базовые функторы для Stmt и Expr и инстансы класса Bifunctor для них:

{-# LANGUAGE LambdaCase #-}

import           Control.Exception      (Exception, handle, throwIO)
import           Control.Monad          (void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Reader   (ReaderT, asks, runReaderT)
import           Data.Bifunctor         (Bifunctor (..))
import           Data.Functor           (($>))
import           Data.IORef             (IORef, modifyIORef, newIORef,
                                         readIORef)
import           Data.List.NonEmpty     (NonEmpty ((:|)))
import           Data.Map.Strict        (Map)
import           Data.Maybe             (fromMaybe)
import           Prelude                hiding (print, seq)

import qualified Data.Map.Strict        as Map
import qualified Prelude

data StmtF stmt expr
    = Assign String expr
    | Print expr
    | Expr expr
    | Seq (NonEmpty stmt)
    deriving Functor

instance Bifunctor StmtF where
    bimap f g = \case
        Assign var e -> Assign var (g e)
        Print e      -> Print (g e)
        Expr e       -> Expr (g e)
        Seq ss       -> Seq $ f <$> ss

data ExprF expr stmt
    = Var String
    | Val Int
    | Binop Binop expr expr
    | If Relop expr expr expr (Maybe expr)
    | ESeq stmt expr
    deriving Functor

instance Bifunctor ExprF where
    bimap f g = \case
        Var var            -> Var var
        Val val            -> Val val
        Binop op e1 e2     -> Binop op (f e1) (f e2)
        If op e1 e2 th mel -> If op (f e1) (f e2) (f th) (f <$> mel)
        ESeq s e           -> ESeq (g s) (f e)

data Binop = Add | Sub | Mul | Div

data Relop = Eq | Ne | Lt | Le | Gt | Ge

Как можно видеть, Fix2 принимает на вход два бифунктора — f и g. f — это тип, значение которого мы хотим получить, а g — тип, который передаётся в качестве параметра в f. Так, если мы ходим получить Stmt, мы сначала передаём StmtF, а потом ExprF. Если же мы хотим получить Expr, делаем наоборот. Обращу внимание, что во втором аргументе f мы меняем местами f и g, потому что первый параметр f нужен для вложенности по f, а второй — для вложенности по g.

newtype Fix2 f g = Fix2 { unFix2 :: f (Fix2 f g) (Fix2 g f) }

Теперь напишем свёртку для Fix2:

cata2 :: (Bifunctor f, Bifunctor g)
      -- Алгебра для f
      => (f a b -> a)
      -- Алгебра для g
      -> (g b a -> b)
      -> Fix2 f g
      -> a
cata2 f g = f . bimap (cata2 f g) (cata2 g f) . unFix2

Также напишем хистоморфизм:

data Cofree2 f g a b = a :< f (Cofree2 f g a b) (Cofree2 g f b a)

histo2 :: (Bifunctor f, Bifunctor g)
      -- Алгебра для f
       => (f (Cofree2 f g a b) (Cofree2 g f b a) -> a)
      -- Алгебра для g
       -> (g (Cofree2 g f b a) (Cofree2 f g a b) -> b)
       -> Fix2 f g
       -> a
histo2 f g fix2 = let a :< _ = go1 fix2 in a
  where go1 = (\x -> f x :< x) . bimap go1 go2 . unFix2
        go2 = (\x -> g x :< x) . bimap go2 go1 . unFix2

Как видно, почти те же самые определения, что и для обычного Fix. Остальные свёртки и развёртки можно написать по аналогии. Теперь приступим к написанию самого интерпретатора:

type InterpretM a = ReaderT Context IO a

newtype Context = Context { ctxVars :: IORef (Map String Int) }

data InterpretError
    = UndefinedVariable String
    | ZeroDivision
    deriving Show

instance Exception InterpretError where

runInterpreter :: Fix2 StmtF ExprF -> IO (Maybe InterpretError)
runInterpreter stmt = do
    ctx <- Context <$> newIORef Map.empty
    let result = cata2 runStmtF runExprF stmt
    handle (pure . Just) (runReaderT result ctx $> Nothing)

runStmtF :: StmtF (InterpretM ()) (InterpretM Int) -> InterpretM ()
runStmtF = \case
    Assign var mVal -> do
        val <- mVal
        varsRef <- asks ctxVars
        liftIO $ modifyIORef varsRef (Map.insert var val)
    Print mVal -> mVal >>= liftIO . Prelude.print
    Expr e     -> void $ e
    Seq ss     -> sequence_ ss

runExprF :: ExprF (InterpretM Int) (InterpretM ()) -> InterpretM Int
runExprF = \case
    Var var -> do
        varsRef <- asks ctxVars
        Map.lookup var <$> liftIO (readIORef varsRef)
        >>= maybe (liftIO $ throwIO $ UndefinedVariable var) pure
    Val val -> pure val
    Binop op mVal1 mVal2 -> do
        val1 <- mVal1
        val2 <- mVal2
        case op of
            Add -> pure (val1 + val2)
            Sub -> pure (val1 - val2)
            Mul -> pure (val1 * val2)
            Div
              | val2 == 0 -> liftIO $ throwIO $ ZeroDivision
              | otherwise -> pure (val1 `div` val2)
    If op me1 me2 mth mel -> do
        e1 <- me1
        e2 <- me2
        if runRelop op e1 e2
           then mth
           else fromMaybe (pure 0) mel
    ESeq s mVal -> s >> mVal

runRelop :: Relop -> Int -> Int -> Bool
runRelop = \case
    Eq -> (==)
    Ne -> (/=)
    Lt -> (<)
    Le -> (<=)
    Gt -> (>)
    Ge -> (>=)

Интерпретатор готов, осталось лишь написать выражения, которые мы будем интерпретировать. Для начала определим вспомогательные функции для конструирования наших выражений:

assign :: String -> Fix2 ExprF StmtF -> Fix2 StmtF ExprF
assign var val = Fix2 $ Assign var val

print :: Fix2 ExprF StmtF -> Fix2 StmtF ExprF
print = Fix2 . Print

expr :: Fix2 ExprF StmtF -> Fix2 StmtF ExprF
expr = Fix2 . Expr

seq :: NonEmpty (Fix2 StmtF ExprF) -> Fix2 StmtF ExprF
seq = Fix2 . Seq

var_ :: String -> Fix2 ExprF StmtF
var_ = Fix2 . Var

val_ :: Int -> Fix2 ExprF StmtF
val_ = Fix2 . Val

binop :: Binop
      -> Fix2 ExprF StmtF
      -> Fix2 ExprF StmtF
      -> Fix2 ExprF StmtF
binop op e1 e2 = Fix2 $ Binop op e1 e2

if_ :: Relop
    -> Fix2 ExprF StmtF
    -> Fix2 ExprF StmtF
    -> Fix2 ExprF StmtF
    -> Maybe (Fix2 ExprF StmtF)
    -> Fix2 ExprF StmtF
if_ op e1 e2 th mel = Fix2 $ If op e1 e2 th mel

eseq :: Fix2 StmtF ExprF -> Fix2 ExprF StmtF -> Fix2 ExprF StmtF
eseq s e = Fix2 $ ESeq s e

Теперь напишем сами выражения:

stmt1 :: Fix2 StmtF ExprF
stmt1 = seq $  assign "a" (val_ 12)
            :| [ assign "b" (binop Mul (binop Add (var_ "a") (val_ 13))
                                       (var_ "a"))
               , expr $ if_ Gt (var_ "b") (val_ 187)
                        (eseq (print (var_ "b")) (val_ 0))
                        (Just $
                            eseq (seq $ (assign "b"
                                            (binop Div (var_ "b")
                                                       (val_ 10)))
                                      :| [print (var_ "b")])
                                 (val_ 0))
               ]

stmt2 :: Fix2 StmtF ExprF
stmt2 = seq $  assign "a" (val_ 0)
            :| [ assign "b" (binop Div (val_ 12) (var_ "a"))
               , print (var_ "b")
               ]

stmt3 :: Fix2 StmtF ExprF
stmt3 = seq $  assign "a" (val_ 12)
            :| [ assign "b" (binop Mul (var_ "a") (var_ "c"))
               , print (var_ "b")
               ]

Далее выполним их интерпретацию:

runAndShowError :: Fix2 StmtF ExprF -> IO ()
runAndShowError s = runInterpreter s >>= \case
    Nothing  -> pure ()
    Just err -> Prelude.print err

main :: IO ()
main = mapM_ runAndShowError [stmt1, stmt2, stmt3]

После запуска в консоль будут напечатаны следующие строки:

300
ZeroDivision
UndefinedVariable "c"