gadts-for-interpreters.hs

----------------------------------------------------------
-- Начинаем с простого язычка

data Expression
  = Val Int
  | Plus Expression Expression

eval :: Expression -> Int
eval (Val x)    = x
eval (Plus x y) = eval x + eval y


----------------------------------------------------------
-- Пытаемся добавить императивность и сайд-эффекты
-- и видим, что нужно различать выражения и стейтменты

data Expression
  = Val Int
  | Plus Expression Expression
  | Read
  | Print Expression
  | Seq [Expression]

eval :: Expression -> IO ??? --- what type?
eval (Val x)    = pure x
eval (Plus x y) = pure $ eval x + eval y
eval Read       = read <$> getLine
eval (Print x)  = print (eval x)
eval (Seq es)   = traverse_ eval es


----------------------------------------------------------
-- Разделяем их по разным типам

import           Control.Applicative (liftA2)

import           Data.Foldable       (traverse_)

data Expression
  = Val Int
  | Plus Expression Expression
  | Read

data Statement
  = Print Expression
  | Seq [Statement]

evalExpression :: Expression -> IO Int
evalExpression (Val x)    = pure x
evalExpression (Plus x y) = liftA2 (+) (evalExpression x) (evalExpression y)
evalExpression Read       = read <$> getLine

evalStatement :: Statement -> IO ()
evalStatement (Print x) = evalExpression x >>= print
evalStatement (Seq xs)  = traverse_ evalStatement xs


----------------------------------------------------------
-- Добавляем два "оператора" для ветвления, один на
-- выражениях, другой на стейтментах

{-# LANGUAGE LambdaCase #-}

import           Control.Applicative (liftA2)

import           Data.Foldable       (traverse_)

data Expression
  = Val Int
  | Plus Expression Expression
  | Read
  | ExpressionIsZero Expression Expression Expression

data Statement
  = Print Expression
  | Seq [Statement]
  | StatementIsZero Expression Statement Statement

evalExpression :: Expression -> IO Int
evalExpression (Val x)                  = pure x
evalExpression (Plus x y)               = liftA2 (+) (evalExpression x) (evalExpression y)
evalExpression Read                     = read <$> getLine
evalExpression (ExpressionIsZero x l r) = evalExpression x >>= \case
    0 -> evalExpression l
    _ -> evalExpression r

evalStatement :: Statement -> IO ()
evalStatement (Print x)               = evalExpression x >>= print
evalStatement (Seq xs)                = traverse_ evalStatement xs
evalStatement (StatementIsZero x l r) = evalExpression x >>= \case
    0 -> evalStatement l
    _ -> evalStatement r


----------------------------------------------------------
-- Но вместо разделения на два типа можно было сделать
-- один ГАДТ с фантомом, тогда
-- - старый Statement  стал Term Statement
-- - старый Expression стал Term Expression

{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE GADTs          #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase     #-}

import           Control.Applicative (liftA2)

import           Data.Foldable       (traverse_)

data TermType = Expression | Statement

data Term (a :: TermType) where
  Val              :: Int -> Term Expression
  Plus             :: Term Expression -> Term Expression -> Term Expression
  Read             :: Term Expression
  ExpressionIsZero :: Term Expression -> Term Expression -> Term Expression -> Term Expression

  Print            :: Term Expression -> Term Statement
  StatementIsZero  :: Term Expression -> Term Statement -> Term Statement -> Term Statement
  Seq              :: [Term Statement] -> Term Statement

evalExpression :: Term Expression -> IO Int
evalExpression (Val x)                  = pure x
evalExpression (Plus x y)               = liftA2 (+) (evalExpression x) (evalExpression y)
evalExpression Read                     = read <$> getLine
evalExpression (ExpressionIsZero x l r) = evalExpression x >>= \case
    0 -> evalExpression l
    _ -> evalExpression r

evalStatement :: Term Statement -> IO ()
evalStatement (Print x)               = evalExpression x >>= print
evalStatement (Seq xs)                = traverse_ evalStatement xs
evalStatement (StatementIsZero x l r) = evalExpression x >>= \case
    0 -> evalStatement l
    _ -> evalStatement r


----------------------------------------------------------
-- Можно заменить свои метки на возвращаемый тип,
-- это позволит заменить два eval на один полиморфный.
-- Делать этого не обязательно, но профит есть.

{-# LANGUAGE GADTs      #-}
{-# LANGUAGE LambdaCase #-}

import           Control.Applicative (liftA2)

import           Data.Foldable       (traverse_)

data Term a where
  Val              :: Int -> Term Int
  Plus             :: Term Int -> Term Int -> Term Int
  Read             :: Term Int
  ExpressionIsZero :: Term Int -> Term Int -> Term Int -> Term Int

  Print            :: Term Int -> Term ()
  StatementIsZero  :: Term Int -> Term () -> Term () -> Term ()
  Seq              :: [Term ()] -> Term ()

eval :: Term a -> IO a
eval (Val x)                  = pure x
eval (Plus x y)               = liftA2 (+) (eval x) (eval y)
eval Read                     = read <$> getLine
eval (ExpressionIsZero x l r) = eval x >>= \case { 0 -> eval l; _ -> eval r }
eval (Print x)                = eval x >>= print
eval (Seq xs)                 = traverse_ eval xs
eval (StatementIsZero x l r)  = eval x >>= \case { 0 -> eval l; _ -> eval r }


----------------------------------------------------------
-- А вот и этот профит - мы можем заменить два ветвления
-- на один полиморфный и не дублировать код выполнения

{-# LANGUAGE GADTs      #-}
{-# LANGUAGE LambdaCase #-}

import           Control.Applicative (liftA2)

import           Data.Foldable       (traverse_)

data Term a where
  Val    :: Int -> Term Int
  Plus   :: Term Int -> Term Int -> Term Int
  Read   :: Term Int

  Print  :: Term Int -> Term ()
  Seq    :: [Term ()] -> Term ()

  IsZero :: Term Int -> Term a -> Term a -> Term a

eval :: Term a -> IO a
eval (Val x)        = pure x
eval (Plus x y)     = liftA2 (+) (eval x) (eval y)
eval Read           = read <$> getLine
eval (Print x)      = eval x >>= print
eval (Seq xs)       = traverse_ eval xs
eval (IsZero x l r) = eval x >>= \case { 0 -> eval l; _ -> eval r }


----------------------------------------------------------
-- Пример

main :: IO ()
main = eval $ Seq
    [ Print (Plus (Val 1) (Val 2))
    , IsZero Read
        (Print (Val 1))
        (Print (Val 2))
    , Print (IsZero (Val 0) (Val 1) (Val 2))
    ]
    -- 3, {0}, 1, 1
    -- 3, {1}, 2, 1