设计简单静态类型语言的类型系统（在Haskell中）

我一直在考虑为一种命令式静态类型语言编写一个解释器，以适应函数式编程和Haskell，但是我从来没有真正记住一个清晰的语法，这常常导致不满意的代码和重写一切的冲动，所以我来这里寻求帮助。我应该如何着手设计一个相对简单但可扩展的类型系统

我想支持基本的原语，如数字类型、布尔值、字符等（在掌握基本知识之前，我不想涉足数组或记录结构）及其相关的基本操作。我最大的问题是，我不知道应该如何实现类型和运算符之间的关系

我还不太了解Haskell，但是定义一系列重复和类型的简单解决方案，如

data ArithmeticOperator =
    Plus
    | Min
    | Mul 
    | Div

data LogicalOperator =
    And
    | Or
    | Not

对我来说似乎没有什么说服力，因为这种类型划分将进一步传播到构建在这些类型（如表达式）上的结构中，并且在计算表达式时必须对每个操作符进行模式匹配似乎非常繁琐，而且不容易扩展

然后我考虑为操作符定义一个灵活的类型，比如

data Operator a b =
    UnaryOperator (a -> b)
    | BinaryOperator (a -> a -> b)

其中a代表参数类型，b代表返回类型。问题是我真的不知道如何强制这些类型成为我想要支持的类型。它看起来更简洁，但我也不确定这是否“正确”

---

最后，有没有以初学者友好的方式介绍此主题的资源？我不想深入研究这个问题，但我很想读一读关于。。嗯，设计类型系统时的一般原则/注意事项

根据评论，不要将此作为您的第一个口译员。如果您还没有为非类型lambda演算编写解释器，或者还没有完成教程，比如，请先这样做

无论如何，这里有一个简单的解释器实现，用于一个静态类型的表达式语言，它具有布尔和数字类型、一些内置操作符（包括一个具有特殊多态性的操作符）、变量和

let x=。。。在…

变量绑定中，但没有lambda。它说明了一种设计类型化解释器的常用方法，但缺少了足够多的内容，不会破坏您的乐趣

注意：我有意避免使用任何中间或高级Haskell特性（例如，

ExprU

和

ExprT

类型没有统一在一个多态类型中——对我们来说不是“”；我没有使用GADTs来输入目标语言；等等）。这些先进的技术可以产生更安全的代码，而且非常棒，因此您肯定希望在将来研究它们，但它们不是让基本类型的解释器工作所必需的

编写解释器时，最好打开

-Wall

——它会提醒您忘记处理哪些模式（即表达式类型）：

{-# OPTIONS_GHC -Wall #-}

此外，为了保持我们的理智，我们需要使用一些单子：

import Control.Monad
import Control.Monad.Reader
import Control.Monad.Except

您在问题中提到，您正在使用两种方法：一种是在开始时按类型划分运算符，另一种是在Haskell类型系统中以某种方式反映运算符类型。你对第一种方法的直觉是正确的——它不会很好地工作。第二种方法是do-able，但是您将很快遇到一些非常先进的Haskell技术，这些技术您可能还没有准备好

相反，对于静态类型语言，让我们从定义一个完全非类型化的抽象表达式语法开始。请注意，这是一种抽象语法，可能由完全不知道类型的解析器生成：

-- Untyped expressions
data ExprU
  = FalseU | TrueU           -- boolean literals
  | NumU Double              -- numeric literal
  | VarU String              -- variable
  | UnU UnOp ExprU           -- unary operator
  | BinU BinOp ExprU ExprU   -- binary operator
  | LetU String ExprU ExprU  -- let x = expr1 in expr2
data UnOp = NegOp | NotOp
  deriving (Show)
data BinOp = PlusOp | MulOp | AndOp | OrOp | EqualsOp
  deriving (Show)

注意，我们可以直接为此编写一个解释器。但是，口译员必须处理类型错误的表达式，如：

BinU PlusOp FalseU (NumU 1)   -- False + 1

这有点违背了定义静态类型语言的全部目的

关键的洞察是，我们可以采用这种非类型化语言，在解释它之前，实际上类型检查它！使用Haskell类型系统对目标语言进行类型检查有一些很酷的技术，但是只定义一个单独的数据类型来表示表达式类型要容易得多：

-- Simple expression types
data Typ
  = BoolT
  | NumT
  deriving (Show, Eq)

对于我们的运营商，也可以方便地为他们提供“类型”：

在一种具有一流函数的语言中，我们可能会将这些类型组合成一个Haskell

Typ

，它不仅可以表示Bool和nums等“原始”类型，还可以表示函数类型，如

Bool->Bool->Bool

，等等。然而，对于这种简单的语言，我们将“表达式类型”和“运算符类型”分开

我们如何处理这些类型？我们使用非类型化表达式

ExprU

，通过向每个表达式添加类型注释来进行类型检查：

-- Typed expressions
data ExprT
  = BoolLit Bool
  | NumLit Double
  | VarT Typ String
  | UnT Typ UnOp ExprT
  | BinT Typ BinOp ExprT ExprT
  | LetT Typ String ExprT ExprT

这里，每个构造函数（文本除外）都有一个

Typ

字段，该字段给出关联表达式的类型。（实际上，我们也可以在文本中添加一个

Typ

字段，即使它是多余的。）使用一个helper函数从

ExprT

中提取类型会很有帮助：

exprTyp :: ExprT -> Typ
exprTyp (BoolLit _) = BoolT
exprTyp (NumLit _) = NumT
exprTyp (VarT t _) = t
exprTyp (UnT t _ _) = t
exprTyp (BinT t _ _ _) = t
exprTyp (LetT t _ _ _) = t

tc :: ExprU -> TC ExprT

类型检查将在跟踪变量类型的monad中进行（我们无法通过检查表达式立即弄清楚的一件事）：

现在，我们可以使用字符串来处理类型错误：

type Error = String

我们的类型检查器非常容易编写。我接受一个非类型化表达式

ExprU

，并添加适当的类型注释以生成一个

ExprT

：

exprTyp :: ExprT -> Typ
exprTyp (BoolLit _) = BoolT
exprTyp (NumLit _) = NumT
exprTyp (VarT t _) = t
exprTyp (UnT t _ _) = t
exprTyp (BinT t _ _ _) = t
exprTyp (LetT t _ _ _) = t

tc :: ExprU -> TC ExprT

创建文本的“类型化版本”很容易：

tc (FalseU) = pure $ BoolLit False
tc (TrueU) = pure $ BoolLit True
tc (NumU x) = pure $ NumLit x

在我们的语言中，变量的类型也很简单。我们只允许在定义变量（通过

LetU

绑定——见下文）后使用变量，因此它们的类型在当前上下文中始终可用：

tc (VarU var) = do
  mt <- asks (lookup var)
  case mt of
    Just t -> pure $ VarT t var
    Nothing -> throwError $ "undefined variable " ++ var

eval (VarT _ var) = do
  mt <- asks (lookup var)
  case mt of
    Just v -> pure $ v
    Nothing -> internalerror

为了

tc (BinU EqualsOp e1 e2) = do
  e1' <- tc e1
  e2' <- tc e2
  let t1 = exprTyp e1'
      t2 = exprTyp e2'
  when (t1 /= t2) $ throwError $ "op EqualOp needs to compare equal types"
  pure $ BinT BoolT EqualsOp e1' e2'

tc (BinU op e1 e2) = do
  let BinTyp targ1 targ2 tresult = binTyp op
  e1' <- tc e1
  e2' <- tc e2
  let t1 = exprTyp e1'
      t2 = exprTyp e2'
  when (t1 /= targ1) $ throwError $ "op " ++ show op ++
    " expected left arg of type " ++ show targ1 ++ ", got " ++ show t1
  when (t2 /= targ2) $ throwError $ "op " ++ show op ++
    " expected right arg of type " ++ show targ2 ++ ", got " ++ show t2
  pure $ BinT tresult op e1' e2'
  where
    binTyp PlusOp = BinTyp NumT NumT NumT
    binTyp MulOp = BinTyp NumT NumT NumT
    binTyp AndOp = BinTyp BoolT BoolT BoolT
    binTyp OrOp = BinTyp BoolT BoolT BoolT
    binTyp EqualsOp = error "internal error"

tc (LetU var e1 e2) = do
  e1' <- tc e1
  let t1 = exprTyp e1'
  e2' <- local ((var,t1):) $ tc e2
  let t2 = exprTyp e2'
  pure $ LetT t2 var e1' e2'

-- Values
data Value
  = BoolV Bool
  | NumV Double
  deriving (Show)

type ValContext = [(String, Value)]   -- context of variable values
type E = Reader ValContext

eval :: ExprT -> E Value

eval (BoolLit b) = pure $ BoolV b
eval (NumLit x) = pure $ NumV x

eval (VarT _ var) = do
  mt <- asks (lookup var)
  case mt of
    Just v -> pure $ v
    Nothing -> internalerror

eval (UnT _ op e) = run op <$> eval e
  where run NegOp (NumV x) = NumV (-x)
        run NotOp (BoolV b) = BoolV (not b)
        run _ _ = internalerror

eval (BinT _ op e1 e2) = run op <$> eval e1 <*> eval e2
  where run EqualsOp (BoolV v1) (BoolV v2) = BoolV $ v1 == v2
        run EqualsOp (NumV v1) (NumV v2) = BoolV $ v1 == v2
        run PlusOp (NumV v1) (NumV v2) = NumV $ v1 + v2
        run MulOp (NumV v1) (NumV v2) = NumV $ v1 * v2
        run AndOp (BoolV v1) (BoolV v2) = BoolV $ v1 && v2
        run OrOp (BoolV v1) (BoolV v2) = BoolV $ v1 || v2
        run _ _ _ = internalerror

  where run EqualsOp v1 v2 = BoolV $ v1 == v2

eval (LetT _ var e1 e2) = do
  v1 <- eval e1
  local ((var,v1):) $ eval e2

{-# OPTIONS_GHC -Wall #-}

import Control.Monad
import Control.Monad.Reader
import Control.Monad.Except

-- Untyped expressions
data ExprU
  = FalseU | TrueU           -- boolean literals
  | NumU Double              -- numeric literal
  | VarU String              -- variable
  | UnU UnOp ExprU           -- unary operator
  | BinU BinOp ExprU ExprU   -- binary operator
  | LetU String ExprU ExprU  -- let x = expr1 in expr2
data UnOp = NegOp | NotOp
  deriving (Show)
data BinOp = PlusOp | MulOp | AndOp | OrOp | EqualsOp
  deriving (Show)

-- Simple expression types
data Typ
  = BoolT
  | NumT
  deriving (Show, Eq)

-- Types of operators
data BinTyp = BinTyp Typ Typ Typ
data UnTyp  = UnTyp Typ Typ

-- Typed expressions
data ExprT
  = BoolLit Bool
  | NumLit Double
  | VarT Typ String
  | UnT Typ UnOp ExprT
  | BinT Typ BinOp ExprT ExprT
  | LetT Typ String ExprT ExprT

exprTyp :: ExprT -> Typ
exprTyp (BoolLit _) = BoolT
exprTyp (NumLit _) = NumT
exprTyp (VarT t _) = t
exprTyp (UnT t _ _) = t
exprTyp (BinT t _ _ _) = t
exprTyp (LetT t _ _ _) = t

-- Type check an expression
type Error = String
type TypContext = [(String, Typ)]   -- context of variable types
type TC = ExceptT Error (Reader TypContext)
runTC :: TC a -> a
runTC act = case runReader (runExceptT act) [] of
  Left err -> error err
  Right a -> a

tc :: ExprU -> TC ExprT
tc (FalseU) = pure $ BoolLit False
tc (TrueU) = pure $ BoolLit True
tc (NumU x) = pure $ NumLit x
tc (VarU var) = do
  mt <- asks (lookup var)
  case mt of
    Just t -> pure $ VarT t var
    Nothing -> throwError $ "undefined variable " ++ var
tc (UnU op e) = do
  let UnTyp targ tresult = unTyp op
  e' <- tc e
  let t = exprTyp e'
  when (t /= targ) $ throwError $ "op " ++ show op ++
    " expected arg of type " ++ show targ ++ ", got " ++ show t
  pure $ UnT tresult op e'
  where
    unTyp NegOp = UnTyp NumT NumT
    unTyp NotOp = UnTyp BoolT BoolT
tc (BinU EqualsOp e1 e2) = do
  e1' <- tc e1
  e2' <- tc e2
  let t1 = exprTyp e1'
      t2 = exprTyp e2'
  when (t1 /= t2) $ throwError $ "op EqualOp needs to compare equal types"
  pure $ BinT BoolT EqualsOp e1' e2'
tc (BinU op e1 e2) = do
  let BinTyp targ1 targ2 tresult = binTyp op
  e1' <- tc e1
  e2' <- tc e2
  let t1 = exprTyp e1'
      t2 = exprTyp e2'
  when (t1 /= targ1) $ throwError $ "op " ++ show op ++
    " expected left arg of type " ++ show targ1 ++ ", got " ++ show t1
  when (t2 /= targ2) $ throwError $ "op " ++ show op ++
    " expected right arg of type " ++ show targ2 ++ ", got " ++ show t2
  pure $ BinT tresult op e1' e2'
  where
    binTyp PlusOp = BinTyp NumT NumT NumT
    binTyp MulOp = BinTyp NumT NumT NumT
    binTyp AndOp = BinTyp BoolT BoolT BoolT
    binTyp OrOp = BinTyp BoolT BoolT BoolT
    binTyp EqualsOp = error "internal error"
tc (LetU var e1 e2) = do
  e1' <- tc e1
  let t1 = exprTyp e1'
  e2' <- local ((var,t1):) $ tc e2
  let t2 = exprTyp e2'
  pure $ LetT t2 var e1' e2'

-- Evaluate a typed expression
internalerror :: a
internalerror = error "can't happen, internal error in type checker"

-- Values
data Value
  = BoolV Bool
  | NumV Double
  deriving (Show)

type ValContext = [(String, Value)]   -- context of variable values
type E = Reader ValContext
runE :: E a -> a
runE act = runReader act []

eval :: ExprT -> E Value
eval (BoolLit b) = pure $ BoolV b
eval (NumLit x) = pure $ NumV x
eval (VarT _ var) = do
  mt <- asks (lookup var)
  case mt of
    Just v -> pure $ v
    Nothing -> internalerror
eval (UnT _ op e) = run op <$> eval e
  where run NegOp (NumV x) = NumV (-x)
        run NotOp (BoolV b) = BoolV (not b)
        run _ _ = internalerror
eval (BinT _ op e1 e2) = run op <$> eval e1 <*> eval e2
  where run EqualsOp (BoolV v1) (BoolV v2) = BoolV $ v1 == v2
        run EqualsOp (NumV v1) (NumV v2) = BoolV $ v1 == v2
        run PlusOp (NumV v1) (NumV v2) = NumV $ v1 + v2
        run MulOp (NumV v1) (NumV v2) = NumV $ v1 * v2
        run AndOp (BoolV v1) (BoolV v2) = BoolV $ v1 && v2
        run OrOp (BoolV v1) (BoolV v2) = BoolV $ v1 || v2
        run _ _ _ = internalerror
eval (LetT _ var e1 e2) = do
  v1 <- eval e1
  local ((var,v1):) $ eval e2

expr1 :: ExprU
expr1 = LetU "x" (BinU PlusOp (NumU 2) (NumU 3)) (LetU "y" (BinU MulOp (VarU "x") (NumU 5)) (BinU EqualsOp (VarU "y") (NumU 25)))

val1 :: Value
val1 = let e1' = runTC (tc expr1) in runE (eval e1')

main :: IO ()
main = do
  print $ val1