系统T组合语言的Haskell解释器

时间：2019-01-01 15:25:41

标签： haskell ocaml interpreter lambda-calculus combinatory-logic

在上一个问题SystemT Compiler and dealing with Infinite Types in Haskell中，我问过如何将SystemT Lambda微积分解析为SystemT组合器。我决定使用普通的代数数据类型对SystemT Lambda微积分和SystemT组合微积分进行编码（基于评论：SystemT Compiler and dealing with Infinite Types in Haskell）。

SystemTCombinator.hs：

module SystemTCombinator where

data THom = Id
          | Unit
          | Zero
          | Succ
          | Compose THom THom
          | Pair THom THom
          | Fst
          | Snd
          | Curry THom
          | Eval
          | Iter THom THom
          deriving (Show)

SystemTLambda.hs：

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE PartialTypeSignatures     #-}
{-# LANGUAGE TypeSynonymInstances      #-}

module SystemTLambda where

import           Control.Monad.Catch
import           Data.Either (fromRight)
import qualified SystemTCombinator    as SystemTC

type TVar = String

data TType = One | Prod TType TType | Arrow TType TType | Nat deriving (Eq)

instance Show TType where
  show ttype = case ttype of
    One -> "'Unit"
    Nat -> "'Nat"
    Prod ttype1 ttype2 ->
      "(" ++ show ttype1 ++ " * " ++ show ttype2 ++ ")"
    Arrow ttype1@(Arrow _ _) ttype2 ->
      "(" ++ show ttype1 ++ ") -> " ++ show ttype2
    Arrow ttype1 ttype2 -> show ttype1 ++ " -> " ++ show ttype2

data TTerm = Var TVar
           | Let TVar TTerm TTerm
           | Lam TVar TTerm
           | App TTerm TTerm
           | Unit
           | Pair TTerm TTerm
           | Fst TTerm
           | Snd TTerm
           | Zero
           | Succ TTerm
           | Iter TTerm TTerm TVar TTerm
           | Annot TTerm TType
           deriving (Show)

-- a context is a list of hypotheses/judgements
type TContext = [(TVar, TType)]

-- our exceptions for SystemT
data TException = TypeCheckException String
                | BindingException String
  deriving (Show)

instance Exception TException

newtype Parser a = Parser { run :: TContext -> Either SomeException a }

instance Functor Parser where
  fmap f xs = Parser $ \ctx ->
    either Left (\v -> Right $ f v) $ run xs ctx

instance Applicative Parser where
  pure a = Parser $ \ctx -> Right a
  fs <*> xs = Parser $ \ctx ->
    either Left (\f -> fmap f $ run xs ctx) (run fs ctx)

instance Monad Parser where
  xs >>= f = Parser $ \ctx ->
    either Left (\v -> run (f v) ctx) $ run xs ctx

instance MonadThrow Parser where
  throwM e = Parser (const $ Left $ toException e)

instance MonadCatch Parser where
  catch p f = Parser $ \ctx ->
    either
      (\e -> case fromException e of
        Just e' -> run (f e') ctx -- this handles the exception
        Nothing -> Left e) -- this propagates it upwards
      Right
      $ run p ctx

withHypothesis :: (TVar, TType) -> Parser a -> Parser a
withHypothesis hyp cmd = Parser $ \ctx -> run cmd (hyp : ctx)

tvarToHom :: TVar -> Parser (SystemTC.THom, TType)
tvarToHom var = Parser $ \ctx ->
  case foldr transform Nothing ctx of
    Just x -> Right x
    Nothing -> throwM $ BindingException ("unbound variable " ++ show var)
  where
    transform (var', varType) homAndType =
      if var == var'
      then Just (SystemTC.Snd, varType)
      else homAndType >>= (\(varHom, varType) -> Just (SystemTC.Compose SystemTC.Fst varHom, varType))

check :: TTerm -> TType -> Parser SystemTC.THom
-- check a lambda
check (Lam var bodyTerm) (Arrow varType bodyType) =
  withHypothesis (var, varType) $
  check bodyTerm bodyType >>= (\bodyHom -> return $ SystemTC.Curry bodyHom)
check (Lam _    _    ) ttype                 = throwM
  $ TypeCheckException ("expected function type, got '" ++ show ttype ++ "'")
-- check unit
check Unit One = return SystemTC.Unit
check Unit ttype =
  throwM $ TypeCheckException ("expected unit type, got '" ++ show ttype ++ "'")
-- check products
check (Pair term1 term2) (Prod ttype1 ttype2) = do
  hom1 <- check term1 ttype1
  hom2 <- check term2 ttype2
  return $ SystemTC.Pair hom1 hom2
check (Pair _      _     ) ttype                = throwM
  $ TypeCheckException ("expected product type, got '" ++ show ttype ++ "'")
-- check primitive recursion
check (Iter baseTerm inductTerm tvar numTerm) ttype = do
  baseHom   <- check baseTerm ttype
  inductHom <- withHypothesis (tvar, ttype) (check inductTerm ttype)
  numHom    <- check numTerm Nat
  return $ SystemTC.Compose (SystemTC.Pair SystemTC.Id numHom)
                            (SystemTC.Iter baseHom inductHom)
-- check let bindings
check (Let var valueTerm exprTerm) exprType = do
  (valueHom, valueType) <- synth valueTerm
  exprHom <- withHypothesis (var, valueType) (check exprTerm exprType)
  return $ SystemTC.Compose (SystemTC.Pair SystemTC.Id valueHom) exprHom
check tterm ttype = do
  (thom, ttype') <- synth tterm
  if ttype == ttype'
    then return thom
    else throwM $ TypeCheckException
      (  "expected type '"
      ++ show ttype
      ++ "', inferred type '"
      ++ show ttype'
      ++ "'"
      )

synth :: TTerm -> Parser (SystemTC.THom, TType)
synth (Var tvar) = tvarToHom tvar
synth (Let var valueTerm exprTerm) = do
  (valueHom, valueType) <- synth valueTerm
  (exprHom, exprType) <- withHypothesis (var, valueType) (synth exprTerm)
  return (SystemTC.Compose (SystemTC.Pair SystemTC.Id valueHom) exprHom, exprType)
synth (App functionTerm valueTerm) = do
  (functionHom, functionType) <- synth functionTerm
  case functionType of
    Arrow headType bodyType -> do
      valueHom <- check valueTerm headType
      return (SystemTC.Compose (SystemTC.Pair functionHom valueHom) SystemTC.Eval, bodyType)
    _ -> throwM $ TypeCheckException ("expected function, got '" ++ show functionType ++ "'")
synth (Fst pairTerm) = do
  (pairHom, pairType) <- synth pairTerm
  case pairType of
    Prod fstType sndType -> return (SystemTC.Compose pairHom SystemTC.Fst, fstType)
    _ -> throwM $ TypeCheckException ("expected product, got '" ++ show pairType ++ "'")
synth (Snd pairTerm) = do
  (pairHom, pairType) <- synth pairTerm
  case pairType of
    Prod fstType sndType -> return (SystemTC.Compose pairHom SystemTC.Snd, sndType)
    _ -> throwM $ TypeCheckException ("expected product, got '" ++ show pairType ++ "'")
synth Zero = return (SystemTC.Compose SystemTC.Unit SystemTC.Zero, Nat)
synth (Succ numTerm) = do
  numHom <- check numTerm Nat
  return (SystemTC.Compose numHom SystemTC.Succ, Nat)
synth (Annot term ttype) = do
  hom <- check term ttype
  return (hom, ttype)
synth _ = throwM $ TypeCheckException "unknown synthesis"

我使用上述双向类型检查器将SystemTLambda.TTerm解析为SystemTCombinator.THom。

systemTLambda :: TTerm
systemTLambda =
  Let "sum"
    (Annot
      (Lam "x" $ Lam "y" $
       Iter (Var "y") (Succ $ Var "n") "n" (Var "x"))
      (Arrow Nat $ Arrow Nat Nat))
    (App
      (App
        (Var "sum")
        (Succ $ Succ Zero))
      (Succ $ Succ $ Succ Zero))

systemTCombinator :: Either SomeException (SystemTC.THom, SystemTC.TType)
systemTCombinator = fromRight Unit $ run (synth result) []

组合器表达式为：

Compose (Pair Id (Curry (Curry (Compose (Pair Id (Compose Fst Snd)) (Iter Snd (Compose Snd Succ)))))) (Compose (Pair (Compose (Pair Snd (Compose (Compose (Compose Unit Zero) Succ) Succ)) Eval) (Compose (Compose (Compose (Compose Unit Zero) Succ) Succ) Succ)) Eval)

我现在遇到的问题是如何解释此组合器表达式。我知道所有组合器表达式都应解释为一个函数。问题是我不知道此函数的输入和输出类型，并且我希望“解释器”功能会是部分的，因为如果它试图错误地解释某些内容，则会导致RuntimeException因为组合器表达式是无类型的，所以可能有错误的组合器表达式。但是，我的类型检查器应确保一旦到达解释器，组合器就应该已经被正确键入。

根据原始博客文章，http://semantic-domain.blogspot.com/2012/12/total-functional-programming-in-partial.html，组合器具有所有等效功能。像这样：

evaluate Id = id
evaluate Unit = const ()
evaluate Zero = \() -> Z
evaluate (Succ n) = S n
evaluate (Compose f g) = (evaluate g) . (evaluate f)
evaluate (Pair l r) = (evaluate l, evaluate r)
evaluate Fst = fst
evaluate Snd = snd
evaluate (Curry h) = curry (evaluate h)
evaluate Eval = \(f, v) -> f v
evaluate (Iter base recurse) = \(a, n) ->
  case n of
    Z   -> evaluate base a
    S n -> evaluate recurse (a, evaluate (Iter base recurse) (a, n))

但是显然那是行不通的。似乎必须有某种方法来解释THom树，这样我才能得到某种可以部分执行的函数。

2 个答案:

答案 0 :(得分：3)

要以保证类型正确的方式解释THom，您需要将其类型“解释”给Haskell类型检查器。我看到您已经考虑过THom的GADT版本，这是进行这种解释的传统方式，而这仍然是我会采用的方法。如果我理解正确，您将面临的麻烦是synth的逻辑太复杂，无法证明它总是会产生类型正确的THom，这不足为奇。

我认为您可以按原样保留synth，如果您添加一个简单的通行证，该通行证会将产生的未键入的THom检入键入的GADT中，请说StrongTHom a b。返回存在物似乎有风险，最好为它提供传入的上下文：

checkTHom :: THom -> TType a -> TType b -> Maybe (StrongTHom a b)

（其中TType是previous answer中的单例形式）。它只需要您在顶层知道输入和输出类型是什么。这通常很好，因为要真正使用结果，您最终将必须知道无论如何都要实例化其结果的类型。 （您可能需要在几个级别上向外扩展此预期的类型信息，直到知道具体类型为止）

如果您绝对必须能够推断输入和输出类型，那么我想除了返回存在性之外别无选择。这只是意味着您的类型检查器将包含更多的类型相等性检查（请参见下面的typeEq），而未键入的THom也可能需要包含更多的类型信息。

无论哪种情况，THom都必须包括其擦除的任何类型。例如，在Compose :: THom a b -> THom b c -> THom a c中，b被删除，checkTHom将不得不对其进行重构。因此Compose需要包含足够的信息，以便有可能。此时，存在性（上一个答案中的SomeType）可能会很好，因为您必须使用它的唯一方法是将其解开并递归传递。

要编写此检查器，我觉得您将需要进行严格的相等性检查：

typeEq :: TType a -> TType b -> Maybe (a :~: b)

（其中:~:是standard type equality），易于编写；我只是确保您知道该技术。

一旦有了这个，eval :: StrongTHom a b -> a -> b就应该像热黄油一样经过。祝你好运！

答案 1 :(得分：2)

或者，通过声明所有可能值的类型来进行运行时类型检查非常容易。

data Value
    = VUnit                          -- of type One
    | VPair Value Value              -- of type Pair
    | VFunc (Value -> Interp Value)  -- of type Func
    | VNat Integer                   -- of type Nat

然后，您可以直接将未键入的THom用于适当的解释器monad Interp（可能只是Except monad）：

eval :: THom -> Value -> Interp Value
eval Id v  = v
eval Unit _ = VUnit
eval Zero VUnit = VNat Zero
eval Succ (VNat n) = VNat (n + 1)
...
eval _ _ = throwE "type error"

还请注意，以上VFunc与eval的共域具有相同的类型，因为嵌入式功能也可能会失败。

相关问题
最新问题