Combine expression representations using the 'trees that grow' design pattern.

Trees that grow introduces a lot of boilerplate but is bound to be essentially necessary
when I add in the type checker and all sorts of builtin data types.
(I know this because I already *implemented* those things;
it's mostly a matter of trying to merge it all into this codebase).

Accomplishing this also involved restructuring the project
and rewriting a few algorithms in the process,
but those changes are fundamentally intwined with this one.
master
James T. Martin 2021-03-16 17:19:50 -07:00
parent 4541f30f46
commit a543981b67
Signed by: james
GPG Key ID: 4B7F3DA9351E577C
17 changed files with 675 additions and 430 deletions

View File

@ -1,19 +1,22 @@
module Main (main) where module Main (main) where
import LambdaCalculus
import Control.Monad (forever) import Control.Monad (forever)
import Data.Text import Data.Text (pack)
import Data.Text.IO qualified as TIO import Data.Text.IO
import LambdaCalculus (eval) import Prelude hiding (putStr, putStrLn, getLine)
import LambdaCalculus.Parser (parseExpression)
import System.IO (hFlush, stdout) import System.IO (hFlush, stdout)
prompt :: Text -> IO Text prompt :: Text -> IO Text
prompt text = do prompt text = do
TIO.putStr text putStr text
hFlush stdout hFlush stdout
TIO.getLine getLine
main :: IO () main :: IO ()
main = forever $ parseExpression <$> prompt ">> " >>= \case main = forever $ parseEval <$> prompt ">> " >>= \case
Left parseError -> putStrLn $ "Parse error: " ++ show parseError Left parseError -> putStrLn $ "Parse error: " <> pack (show parseError)
Right expr -> print $ eval expr -- TODO: Support choosing which version to use at runtime.
Right expr -> putStrLn $ unparseEval $ eval expr
--Right expr -> mapM_ (putStrLn . unparseEval) $ snd $ traceEval expr

View File

@ -14,18 +14,25 @@ extra-source-files:
default-extensions: default-extensions:
- BlockArguments - BlockArguments
- DefaultSignatures
- EmptyCase
- EmptyDataDeriving
- FlexibleContexts - FlexibleContexts
- FlexibleInstances
- ImportQualifiedPost - ImportQualifiedPost
- LambdaCase - LambdaCase
- OverloadedStrings - OverloadedStrings
- PatternSynonyms - PatternSynonyms
- StandaloneDeriving
- ViewPatterns - ViewPatterns
# Required for use of recursion-schemes # Required for use of the 'trees that grow' pattern
- MultiParamTypeClasses
- TypeFamilies
# Used by recursion-schemes when using template haskell
- DeriveFoldable - DeriveFoldable
- DeriveFunctor - DeriveFunctor
- DeriveTraversable - DeriveTraversable
- TemplateHaskell - TemplateHaskell
- TypeFamilies
dependencies: dependencies:
- base >= 4.14 && < 5 - base >= 4.14 && < 5
@ -33,7 +40,6 @@ dependencies:
- parsec >= 3.1 && < 4 - parsec >= 3.1 && < 4
- recursion-schemes >= 5.2 && < 6 - recursion-schemes >= 5.2 && < 6
- text >= 1.2 && < 2 - text >= 1.2 && < 2
- text-show >= 3.9 && < 4
- unordered-containers >= 0.2.13 && < 0.3 - unordered-containers >= 0.2.13 && < 0.3
library: library:
@ -48,9 +54,10 @@ library:
- -Wno-implicit-prelude - -Wno-implicit-prelude
- -Wno-missing-deriving-strategies - -Wno-missing-deriving-strategies
# Less stupid warnings, but I still don't care # Less stupid warnings, but I still don't care
- -Wno-unused-do-bind
- -Wno-all-missed-specialisations - -Wno-all-missed-specialisations
- -Wno-missing-local-signatures - -Wno-missing-local-signatures
# This is a good warning, but often polymorphism isn't actually needed.
- -Wno-monomorphism-restriction
# Explicit import lists are generally a good thing, but I don't want them # Explicit import lists are generally a good thing, but I don't want them
# in certain cases (e.g. importing my own modules, task-specific modules like the parser). # in certain cases (e.g. importing my own modules, task-specific modules like the parser).
- -Wno-missing-import-lists - -Wno-missing-import-lists

View File

@ -1,9 +1,12 @@
module Data.Stream (Stream (Cons), filter, fromList) where module Data.Stream
( Stream (..)
, filter, iterate, fromList
) where
import Data.Functor.Foldable (Base, Corecursive, Recursive, embed, project, ana) import Data.Functor.Foldable (Base, Corecursive, Recursive, embed, project, ana)
import Prelude hiding (filter, head, tail) import Prelude hiding (filter, iterate, head, tail)
data Stream a = Cons a (Stream a) data Stream a = Cons { head :: a, tail :: Stream a }
type instance Base (Stream a) = (,) a type instance Base (Stream a) = (,) a
@ -19,6 +22,9 @@ filter p = ana \case
| p x -> (x, xs) | p x -> (x, xs)
| otherwise -> project xs | otherwise -> project xs
iterate :: (a -> a) -> a -> Stream a
iterate f = ana \x -> (x, f x)
fromList :: [a] -> Stream a fromList :: [a] -> Stream a
fromList = ana coalg fromList = ana coalg
where where

View File

@ -1,156 +1,16 @@
module LambdaCalculus module LambdaCalculus
( module LambdaCalculus.Expression ( module LambdaCalculus.Evaluator
, eval, traceEval , module LambdaCalculus.Expression
, module LambdaCalculus.Syntax
, parseEval, unparseEval
) where ) where
import Control.Monad.Except (MonadError, ExceptT, throwError, runExceptT) import LambdaCalculus.Evaluator
import Control.Monad.State (MonadState, State, evalState, modify', state, put, gets) import LambdaCalculus.Expression
import Control.Monad.Writer (runWriterT, tell) import LambdaCalculus.Syntax
import Data.Functor.Foldable (cata, para, project, embed)
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Stream (Stream)
import Data.Stream qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void, absurd)
import LambdaCalculus.Continuation
import LambdaCalculus.Expression (Expression (..), ExpressionF (..))
-- | Free variables are variables which are present in an expression but not bound by any abstraction. parseEval :: Text -> Either ParseError EvalExpr
freeVariables :: Expression -> HashSet Text parseEval = fmap ast2eval . parseAST
freeVariables = cata \case
VariableF name -> HS.singleton name
ApplicationF e1 e2 -> HS.union e1 e2
AbstractionF n e -> HS.delete n e
ContinuationF e -> HS.delete "!" e
-- | Bound variables are variables which are bound by any form of abstraction in an expression. unparseEval :: EvalExpr -> Text
boundVariables :: Expression -> HashSet Text unparseEval = unparseAST . simplify . eval2ast
boundVariables = cata \case
VariableF _ -> HS.empty
ApplicationF e1 e2 -> HS.union e1 e2
AbstractionF n e -> HS.insert n e
ContinuationF e -> HS.insert "!" e
-- | Variables that occur anywhere in an experession, bound or free.
usedVariables :: Expression -> HashSet Text
usedVariables x = HS.union (freeVariables x) (boundVariables x)
-- | Generate a stream of new variables which are not in the set of provided variables.
freshVariables :: HashSet Text -> Stream Text
freshVariables ctx = S.filter (not . flip HS.member ctx) $ S.fromList $ fmap T.pack $ (:) <$> ['a'..'z'] <*> map show [0 :: Int ..]
-- | Create a new variable which is not used anywhere else.
fresh :: State (Stream Text) Text
fresh = state project
-- | Substitution is the process of replacing all free occurrences of a variable in one expression with another expression.
substitute :: Text -> Expression -> Expression -> Expression
substitute var val = unsafeSubstitute var val . alphaConvert (usedVariables val)
-- | Rename the bound variables in `e` so they do not overlap any variables used in `ctx`.
--
-- This is used as part of substitution when substituting `val` with free variables `ctx` into `e`,
-- because it prevents any of the binders in `e` from accidentally capturing a free variable in `ctx`.
alphaConvert :: HashSet Text -> Expression -> Expression
alphaConvert ctx e_ = evalState (rename e_) $ freshVariables $ HS.union (usedVariables e_) ctx
where
rename :: Expression -> State (Stream Text) Expression
rename = cata \case
VariableF var -> pure $ Variable var
ApplicationF ef ex -> Application <$> ef <*> ex
ContinuationF e -> Continuation <$> e
AbstractionF n e
| HS.member n ctx -> do
n' <- fresh
Abstraction n' . unsafeSubstitute n (Variable n') <$> e
| otherwise -> Abstraction n <$> e
-- | Substitution with the assumption that no free variables in the value are bound in the expression.
unsafeSubstitute :: Text -> Expression -> Expression -> Expression
unsafeSubstitute var val = para \case
e'
| VariableF var2 <- e', var == var2 -> val
| ApplicationF (_, ef) (_, ex) <- e' -> Application ef ex
| ContinuationF (_, e) <- e', var /= "!" -> Continuation e
| AbstractionF var2 (_, e) <- e', var /= var2 -> Abstraction var2 e
| otherwise -> embed $ fmap fst e'
isReducible :: Expression -> Bool
isReducible = snd . cata \case
ApplicationF ctr args -> eliminator ctr [args]
VariableF "callcc" -> constructor
AbstractionF _ _ -> constructor
ContinuationF _ -> constructor
VariableF _ -> constant
where
-- | Constants are irreducible in any context.
constant = (False, False)
-- | Constructors are reducible if an eliminator is applied to them.
constructor = (True, False)
-- | Eliminators are reducible if they are applied to a constructor or their arguments are reducible.
eliminator ctr args = (False, fst ctr || snd ctr || any snd args)
push :: MonadState Continuation m => ContinuationCrumb -> m ()
push c = modify' (c :)
pop :: MonadState Continuation m => m (Maybe ContinuationCrumb)
pop = state \case
[] -> (Nothing, [])
(crumb:k) -> (Just crumb, k)
ret :: (MonadError Expression m, MonadState Continuation m) => Expression -> m Expression
ret e = pop >>= maybe (throwError e) (pure . continue1 e)
-- | Iteratively perform an action forever (or at least until it performs a control flow effect).
iterateM_ :: Monad m => (a -> m a) -> a -> m b
iterateM_ m = m' where m' x = m x >>= m'
fromLeft :: Either a Void -> a
fromLeft (Left x) = x
fromLeft (Right x) = absurd x
-- | Iteratively call an action until it 'throws' a return value.
loop :: Monad m => (a -> ExceptT b m a) -> a -> m b
loop f = fmap fromLeft . runExceptT . iterateM_ f
-- | A call-by-value expression evaluator.
evaluatorStep :: (MonadError Expression m, MonadState Continuation m) => Expression -> m Expression
evaluatorStep = \case
unmodified@(Application ef ex)
-- First reduce the argument...
| isReducible ex -> do
push (AppliedTo ef)
pure ex
-- then reduce the function...
| isReducible ef -> do
push (ApplyTo ex)
pure ef
| otherwise -> case ef of
-- perform beta reduction if possible...
Abstraction name body ->
pure $ substitute name ex body
-- perform continuation calls if possible...
Continuation body -> do
put []
pure $ substitute "!" ex body
-- capture the current continuation if requested...
Variable "callcc" -> do
-- Don't worry about variable capture here for now.
k <- gets $ continue (Variable "!")
pure $ Application ex (Continuation k)
-- otherwise the value is irreducible and we can continue evaluation.
_ -> ret unmodified
-- Neither abstractions nor variables are reducible.
e -> ret e
eval :: Expression -> Expression
eval = flip evalState [] . loop evaluatorStep
traceEval :: Expression -> (Expression, [Expression])
traceEval = flip evalState [] . runWriterT . loop \e -> do
-- You can also use `gets (continue e)` to print the *entire* expression each step.
-- This is a trade-off because it becomes much harder to pick out what changed from the rest of the expression.
tell [e]
evaluatorStep e

View File

@ -0,0 +1,171 @@
module LambdaCalculus.Evaluator
( Expr (..), ExprF (..), VoidF, Text
, Eval, EvalExpr, EvalX, EvalXF (..)
, pattern AppFE, pattern Cont, pattern ContF
, eval, traceEval
) where
import LambdaCalculus.Evaluator.Base
import LambdaCalculus.Evaluator.Continuation
import Control.Monad.Except (MonadError, ExceptT, throwError, runExceptT)
import Control.Monad.State (MonadState, State, evalState, modify', state, put, gets)
import Control.Monad.Writer (runWriterT, tell)
import Data.Functor.Foldable (cata, para, embed)
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Stream qualified as S
import Data.Text qualified as T
import Data.Void (Void, absurd)
-- | Free variables are variables which are present in an expression but not bound by any abstraction.
freeVars :: EvalExpr -> HashSet Text
freeVars = cata \case
VarF name -> HS.singleton name
AppFE e1 e2 -> HS.union e1 e2
AbsF n e -> HS.delete n e
ContF e -> HS.delete "!" e
-- | Bound variables are variables which are bound by any form of abstraction in an expression.
boundVars :: EvalExpr -> HashSet Text
boundVars = cata \case
VarF _ -> HS.empty
AppFE e1 e2 -> HS.union e1 e2
AbsF n e -> HS.insert n e
ContF e -> HS.insert "!" e
-- | Vars that occur anywhere in an experession, bound or free.
usedVars :: EvalExpr -> HashSet Text
usedVars x = HS.union (freeVars x) (boundVars x)
-- | Substitution is the process of replacing all free occurrences of a variable in one expression with another expression.
substitute :: Text -> EvalExpr -> EvalExpr -> EvalExpr
substitute var val = unsafeSubstitute var val . alphaConvert (freeVars val)
-- | Substitution is only safe if the bound variables in the body
-- are disjoint from the free variables in the argument;
-- this function makes an expression body safe for substitution
-- by replacing the bound variables in the body
-- with completely new variables which do not occur in either expression
-- (without changing any *free* variables in the body, of course).
alphaConvert :: HashSet Text -> EvalExpr -> EvalExpr
alphaConvert ctx e_ = evalState (alphaConverter e_) $ HS.union ctx (usedVars e_)
where
alphaConverter :: EvalExpr -> State (HashSet Text) EvalExpr
alphaConverter = cata \case
e
| AbsF n e' <- e, n `HS.member` ctx -> do
n' <- fresh n
e'' <- e'
pure $ Abs n' $ replace n n' e''
| otherwise -> embed <$> sequenceA e
-- | Create a new name which is not used anywhere else.
fresh :: Text -> State (HashSet Text) Text
fresh n = state \ctx' ->
let n' = S.head $ S.filter (not . (`HS.member` ctx')) names
in (n', HS.insert n' ctx')
where names = S.iterate (`T.snoc` '\'') n
-- | Replace a name with an entirely new name in all contexts.
-- This will only give correct results if
-- the new name does not occur anywhere in the expression.
replace :: Text -> Text -> EvalExpr -> EvalExpr
replace name name' = cata \case
e
| VarF name2 <- e, name == name2 -> Var name'
| AbsF name2 e' <- e, name == name2 -> Abs name' e'
| otherwise -> embed e
-- | Substitution which does *not* avoid variable capture;
-- it only gives the correct result if the bound variables in the body
-- are disjoint from the free variables in the argument.
unsafeSubstitute :: Text -> EvalExpr -> EvalExpr -> EvalExpr
unsafeSubstitute var val = para \case
e'
| VarF var2 <- e', var == var2 -> val
| AbsF var2 _ <- e', var == var2 -> unmodified e'
| ContF _ <- e', var == "!" -> unmodified e'
| otherwise -> substituted e'
where
substituted = embed . fmap snd
unmodified = embed . fmap fst
isReducible :: EvalExpr -> Bool
isReducible = snd . cata \case
AppF ctr (Identity args) -> eliminator ctr [args]
VarF "callcc" -> constructor
AbsF _ _ -> constructor
ContF _ -> constructor
VarF _ -> constant
where
-- | Constants are irreducible in any context.
constant = (False, False)
-- | Constructors are reducible if an eliminator is applied to them.
constructor = (True, False)
-- | Eliminators are reducible if they are applied to a constructor or their arguments are reducible.
eliminator ctr args = (False, fst ctr || snd ctr || any snd args)
push :: MonadState Continuation m => ContinuationCrumb -> m ()
push c = modify' (c :)
pop :: MonadState Continuation m => m (Maybe ContinuationCrumb)
pop = state \case
[] -> (Nothing, [])
(crumb:k) -> (Just crumb, k)
ret :: (MonadError EvalExpr m, MonadState Continuation m) => EvalExpr -> m EvalExpr
ret e = pop >>= maybe (throwError e) (pure . continue1 e)
-- | Iteratively perform an action forever (or at least until it performs a control flow effect).
iterateM_ :: Monad m => (a -> m a) -> a -> m b
iterateM_ m = m' where m' x = m x >>= m'
fromLeft :: Either a Void -> a
fromLeft (Left x) = x
fromLeft (Right x) = absurd x
-- | Iteratively call an action until it 'throws' a return value.
loop :: Monad m => (a -> ExceptT b m a) -> a -> m b
loop f = fmap fromLeft . runExceptT . iterateM_ f
-- | A call-by-value expression evaluator.
evaluatorStep :: (MonadError EvalExpr m, MonadState Continuation m) => EvalExpr -> m EvalExpr
evaluatorStep = \case
unmodified@(App ef ex)
-- First reduce the argument...
| isReducible ex -> do
push (AppliedTo ef)
pure ex
-- then reduce the function...
| isReducible ef -> do
push (ApplyTo ex)
pure ef
| otherwise -> case ef of
-- perform beta reduction if possible...
Abs name body ->
pure $ substitute name ex body
-- perform continuation calls if possible...
Cont body -> do
put []
pure $ substitute "!" ex body
-- capture the current continuation if requested...
Var "callcc" -> do
-- Don't worry about variable capture here for now.
k <- gets $ continue (Var "!")
pure $ App ex (Cont k)
-- otherwise the value is irreducible and we can continue evaluation.
_ -> ret unmodified
-- Neither abstractions nor variables are reducible.
e -> ret e
eval :: EvalExpr -> EvalExpr
eval = flip evalState [] . loop evaluatorStep
traceEval :: EvalExpr -> (EvalExpr, [EvalExpr])
traceEval = flip evalState [] . runWriterT . loop \e -> do
-- You can also use `gets (continue e)` to print the *entire* expression each step.
-- This is a trade-off because it becomes much harder to pick out what changed from the rest of the expression.
e' <- gets (continue e)
tell [e']
evaluatorStep e

View File

@ -0,0 +1,52 @@
module LambdaCalculus.Evaluator.Base
( Identity (..)
, Expr (..), ExprF (..), VoidF, Text
, Eval, EvalExpr, EvalExprF, EvalX, EvalXF (..)
, pattern AppFE, pattern Cont, pattern ContF
) where
import LambdaCalculus.Expression.Base
import Data.Functor.Identity (Identity (..))
data Eval
type EvalExpr = Expr Eval
type instance AppArgs Eval = EvalExpr
type instance AbsArgs Eval = Text
type instance LetArgs Eval = VoidF EvalExpr
type instance XExpr Eval = EvalX
type EvalX = EvalXF EvalExpr
type EvalExprF = ExprF Eval
type instance AppArgsF Eval = Identity
type instance LetArgsF Eval = VoidF
type instance XExprF Eval = EvalXF
newtype EvalXF r
-- | A continuation. This is identical to a lambda abstraction,
-- with the exception that it performs the side-effect of
-- deleting the current continuation.
--
-- Continuations do not have any corresponding surface-level syntax,
-- but may be printed like a lambda with the illegal variable `!`.
= Cont_ r
deriving (Eq, Functor, Foldable, Traversable, Show)
instance RecursivePhase Eval where
projectAppArgs = Identity
embedAppArgs = runIdentity
pattern Cont :: EvalExpr -> EvalExpr
pattern Cont e = ExprX (Cont_ e)
pattern ContF :: r -> EvalExprF r
pattern ContF e = ExprXF (Cont_ e)
pattern AppFE :: r -> r -> EvalExprF r
pattern AppFE ef ex = AppF ef (Identity ex)
{-# COMPLETE Var, App, Abs, Let, Cont #-}
{-# COMPLETE VarF, AppF, AbsF, LetF, ContF #-}
{-# COMPLETE VarF, AppFE, AbsF, LetF, ExprXF #-}
{-# COMPLETE VarF, AppFE, AbsF, LetF, ContF #-}

View File

@ -1,26 +1,26 @@
module LambdaCalculus.Continuation module LambdaCalculus.Evaluator.Continuation
( Continuation, continue, continue1 ( Continuation, continue, continue1
, ContinuationCrumb (ApplyTo, AppliedTo, AbstractedOver) , ContinuationCrumb (ApplyTo, AppliedTo, AbstractedOver)
) where ) where
import LambdaCalculus.Evaluator.Base
import Data.List (foldl') import Data.List (foldl')
import Data.Text (Text)
import LambdaCalculus.Expression
data ContinuationCrumb data ContinuationCrumb
-- | The one-hole context of a function application: `(_ e)` -- | The one-hole context of a function application: `(_ e)`
= ApplyTo Expression = ApplyTo EvalExpr
-- | The one-hole context of the argument to a function application: `(f _)` -- | The one-hole context of the argument to a function application: `(f _)`
| AppliedTo Expression | AppliedTo EvalExpr
-- | The one-hole context of the body of a lambda abstraction: `(λx. _)` -- | The one-hole context of the body of a lambda abstraction: `(λx. _)`
| AbstractedOver Text | AbstractedOver Text
type Continuation = [ContinuationCrumb] type Continuation = [ContinuationCrumb]
continue1 :: Expression -> ContinuationCrumb -> Expression continue1 :: EvalExpr -> ContinuationCrumb -> EvalExpr
continue1 e (ApplyTo x) = Application e x continue1 e (ApplyTo x) = App e x
continue1 e (AppliedTo x) = Application x e continue1 e (AppliedTo x) = App x e
continue1 e (AbstractedOver name) = Abstraction name e continue1 e (AbstractedOver name) = Abs name e
continue :: Expression -> Continuation -> Expression continue :: EvalExpr -> Continuation -> EvalExpr
continue = foldl' continue1 continue = foldl' continue1

View File

@ -1,96 +1,33 @@
module LambdaCalculus.Expression module LambdaCalculus.Expression
( Expression (..), ExpressionF (..) ( Expr (..), ExprF (..), DefF (..), VoidF, Text
, ast2expr, expr2ast , Eval, EvalExpr, EvalX, EvalXF (..), Identity (..)
, pattern Lets, pattern Abstractions, pattern Applications , pattern AppFE, pattern Cont, pattern ContF
, viewLet, viewAbstraction, viewApplication , Parse, AST, ASTF, NonEmptyDefFs (..), NonEmpty (..), simplify
, pattern LetFP
, ast2eval, eval2ast
) where ) where
-- The definition of Expression is in its own file because: import LambdaCalculus.Evaluator.Base
-- * Expression and AbstractSyntax should not be in the same file import LambdaCalculus.Syntax.Base
-- * Expression's `show` definition depends on AbstractSyntax's show definition,
-- which means that `ast2expr` and `expr2ast` can't be in AbstractSyntax
-- because of mutually recursive modules
-- * I don't want to clutter the module focusing on the actual evaluation
-- with all of these irrelevant conversion operators.
import Data.Bifunctor (first) import Data.Functor.Foldable (cata, hoist)
import Data.Functor.Foldable (ana, cata) import Data.List (foldl')
import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.List.NonEmpty (toList)
import Data.List (foldl1')
import Data.List.NonEmpty (NonEmpty ((:|)), fromList, toList)
import Data.Text (Text)
import Data.Text qualified as T
import LambdaCalculus.Parser.AbstractSyntax (AbstractSyntax)
import LambdaCalculus.Parser.AbstractSyntax qualified as AST
import TextShow (TextShow, showb, showt)
data Expression -- | Convert from an abstract syntax tree to an evaluator expression.
= Variable Text ast2eval :: AST -> EvalExpr
-- | Function application: `(f x)`. ast2eval = cata \case
| Application Expression Expression VarF name -> Var name
-- | Lambda abstraction: `(λx. e)`. AppF ef exs -> foldl' App ef $ toList exs
| Abstraction Text Expression AbsF ns e -> foldr Abs e $ toList ns
-- | A continuation. This is identical to a lambda abstraction, LetF ds e ->
-- with the exception that it performs the side-effect of let letExpr name val body' = App (Abs name body') val
-- deleting the current continuation. in foldr (uncurry letExpr) e $ getNonEmptyDefFs ds
--
-- Continuations do not have any corresponding surface-level syntax.
| Continuation Expression
deriving Eq
makeBaseFunctor ''Expression -- | Convert from an evaluator expression to an abstract syntax tree.
eval2ast :: EvalExpr -> AST
-- | Convert from an abstract syntax tree to an expression. eval2ast = hoist \case
ast2expr :: AbstractSyntax -> Expression VarF name -> VarF name
ast2expr = cata \case AppFE ef ex -> AppF ef (ex :| [])
AST.VariableF name -> Variable name AbsF n e -> AbsF (n :| []) e
AST.ApplicationF es -> case es of ContF e -> AbsF ("!" :| []) e
x :| [] -> x
xs -> foldl1' Application (toList xs)
AST.AbstractionF names body -> foldr Abstraction body (toList names)
AST.LetF defs body ->
let letExpr name val body' = Application (Abstraction name body') val
in foldr (uncurry letExpr) body defs
-- | View nested applications of abstractions as a list.
pattern Lets :: [(Text, Expression)] -> Expression -> Expression
pattern Lets defs body <- (viewLet -> (defs@(_:_), body))
viewLet :: Expression -> ([(Text, Expression)], Expression)
viewLet (Application (Abstraction var body) x) = first ((var, x) :) (viewLet body)
viewLet x = ([], x)
-- | View nested abstractions as a list.
pattern Abstractions :: [Text] -> Expression -> Expression
pattern Abstractions names body <- (viewAbstraction -> (names@(_:_), body))
viewAbstraction :: Expression -> ([Text], Expression)
viewAbstraction (Abstraction name body) = first (name :) (viewAbstraction body)
viewAbstraction x = ([], x)
-- | View left-nested applications as a list.
pattern Applications :: [Expression] -> Expression
pattern Applications exprs <- (viewApplication -> exprs@(_:_:_))
{-# COMPLETE Abstractions, Applications, Continuation, Variable :: Expression #-}
viewApplication :: Expression -> [Expression]
viewApplication (Application ef ex) = viewApplication ef ++ [ex]
viewApplication x = [x]
-- | Convert from an expression to an abstract syntax tree.
--
-- This function will use let, and applications and abstractions of multiple values when possible.
expr2ast :: Expression -> AbstractSyntax
expr2ast = ana \case
Lets defs body -> AST.LetF (fromList defs) body
Abstractions names body -> AST.AbstractionF (fromList names) body
Applications exprs -> AST.ApplicationF $ fromList exprs
Continuation body -> AST.AbstractionF ("!" :| []) body
Variable name -> AST.VariableF name
instance TextShow Expression where
showb = showb . expr2ast
instance Show Expression where
show = T.unpack . showt

View File

@ -0,0 +1,166 @@
{-# LANGUAGE UndecidableInstances #-}
module LambdaCalculus.Expression.Base
( Text, VoidF, absurd'
, Expr (..), Def, AppArgs, AbsArgs, LetArgs, XExpr
, ExprF (..), DefF (..), AppArgsF, LetArgsF, XExprF
, RecursivePhase, projectAppArgs, projectLetArgs, projectXExpr, projectDef
, embedAppArgs, embedLetArgs, embedXExpr, embedDef
) where
import Data.Functor.Foldable (Base, Recursive, Corecursive, project, embed)
import Data.Kind (Type)
import Data.Text (Text)
data Expr phase
-- | A variable: `x`.
= Var !Text
-- | Function application: `f x_0 ... x_n`.
| App !(Expr phase) !(AppArgs phase)
-- | Lambda abstraction: `λx_0 ... x_n. e`.
| Abs !(AbsArgs phase) !(Expr phase)
-- | Let expression: `let x_0 = v_0 ... ; x_n = v_n in e`.
| Let !(LetArgs phase) !(Expr phase)
-- | Additional phase-specific constructors.
| ExprX !(XExpr phase)
deriving instance
( Eq (AppArgs phase)
, Eq (AbsArgs phase)
, Eq (LetArgs phase)
, Eq (XExpr phase)
) => Eq (Expr phase)
deriving instance
( Show (AppArgs phase)
, Show (AbsArgs phase)
, Show (LetArgs phase)
, Show (XExpr phase)
) => Show (Expr phase)
type family AppArgs phase
type family AbsArgs phase
type family LetArgs phase
type family XExpr phase
-- | A definition, mapping a name to a value.
type Def phase = (Text, Expr phase)
---
--- Base functor boilerplate for recursion-schemes
---
data ExprF phase r
= VarF !Text
| AppF !r !(AppArgsF phase r)
| AbsF !(AbsArgs phase) r
| LetF !(LetArgsF phase r) r
| ExprXF !(XExprF phase r)
type instance Base (Expr phase) = ExprF phase
type family AppArgsF phase :: Type -> Type
type family LetArgsF phase :: Type -> Type
type family XExprF phase :: Type -> Type
data DefF r = DefF !Text !r
deriving (Eq, Functor, Show)
-- | An empty type with one extra type parameter.
data VoidF a
deriving (Eq, Functor, Foldable, Traversable, Show)
absurd' :: VoidF a -> b
absurd' x = case x of {}
instance
( Functor (AppArgsF phase)
, Functor (LetArgsF phase)
, Functor (XExprF phase)
) => Functor (ExprF phase) where
fmap f = \case
VarF n -> VarF n
AppF ef exs -> AppF (f ef) (fmap f exs)
AbsF ns e -> AbsF ns (f e)
LetF ds e -> LetF (fmap f ds) (f e)
ExprXF q -> ExprXF (fmap f q)
instance
( Foldable (AppArgsF phase)
, Foldable (LetArgsF phase)
, Foldable (XExprF phase)
) => Foldable (ExprF phase) where
foldMap f = \case
VarF _ -> mempty
AppF ef exs -> f ef <> foldMap f exs
AbsF _ e -> f e
LetF ds e -> foldMap f ds <> f e
ExprXF q -> foldMap f q
instance
( Traversable (AppArgsF phase)
, Traversable (LetArgsF phase)
, Traversable (XExprF phase)
) => Traversable (ExprF phase) where
traverse f = \case
VarF n -> pure $ VarF n
AppF ef exs -> AppF <$> f ef <*> traverse f exs
AbsF ns e -> AbsF ns <$> f e
LetF ds e -> LetF <$> traverse f ds <*> f e
ExprXF q -> ExprXF <$> traverse f q
class Functor (ExprF phase) => RecursivePhase phase where
projectAppArgs :: AppArgs phase -> AppArgsF phase (Expr phase)
projectLetArgs :: LetArgs phase -> LetArgsF phase (Expr phase)
projectXExpr :: XExpr phase -> XExprF phase (Expr phase)
embedAppArgs :: AppArgsF phase (Expr phase) -> AppArgs phase
embedLetArgs :: LetArgsF phase (Expr phase) -> LetArgs phase
embedXExpr :: XExprF phase (Expr phase) -> XExpr phase
default projectAppArgs :: AppArgs phase ~ AppArgsF phase (Expr phase)
=> AppArgs phase -> AppArgsF phase (Expr phase)
default projectLetArgs :: LetArgs phase ~ LetArgsF phase (Expr phase)
=> LetArgs phase -> LetArgsF phase (Expr phase)
default projectXExpr :: XExpr phase ~ XExprF phase (Expr phase)
=> XExpr phase -> XExprF phase (Expr phase)
default embedAppArgs :: AppArgsF phase (Expr phase) ~ AppArgs phase
=> AppArgsF phase (Expr phase) -> AppArgs phase
default embedLetArgs :: LetArgsF phase (Expr phase) ~ LetArgs phase
=> LetArgsF phase (Expr phase) -> LetArgs phase
default embedXExpr :: XExprF phase (Expr phase) ~ XExpr phase
=> XExprF phase (Expr phase) -> XExpr phase
projectAppArgs = id
projectLetArgs = id
projectXExpr = id
embedAppArgs = id
embedLetArgs = id
embedXExpr = id
projectDef :: Def phase -> DefF (Expr phase)
projectDef = uncurry DefF
embedDef :: DefF (Expr phase) -> Def phase
embedDef (DefF n e) = (n, e)
instance RecursivePhase phase => Recursive (Expr phase) where
project = \case
Var n -> VarF n
App ef exs -> AppF ef (projectAppArgs exs)
Abs ns e -> AbsF ns e
Let ds e -> LetF (projectLetArgs ds) e
ExprX q -> ExprXF (projectXExpr q)
instance RecursivePhase phase => Corecursive (Expr phase) where
embed = \case
VarF n -> Var n
AppF ef exs -> App ef (embedAppArgs exs)
AbsF ns e -> Abs ns e
LetF ds e -> Let (embedLetArgs ds) e
ExprXF q -> ExprX (embedXExpr q)
---
--- End base functor boilerplate.
---

View File

@ -1,96 +0,0 @@
module LambdaCalculus.Parser.AbstractSyntax
( AbstractSyntax (..), AbstractSyntaxF (..), Definition, Identifier
) where
import Data.Functor.Base (NonEmptyF (NonEmptyF))
import Data.Functor.Foldable (cata)
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.List.NonEmpty (NonEmpty, toList)
import Data.Text (Text)
import Data.Text qualified as T
import TextShow (Builder, TextShow, showb, showt, toText, fromText)
-- | The abstract syntax tree reflects the structure of the externally-visible syntax.
--
-- This contains a lot of syntactic sugar when compared with 'LambdaCalculus.Expression'.
-- If this syntactic sugar were used in Expression, then operations like evaluation
-- would become unnecessarily complicated, because the same expression
-- can be represented in terms of multiple abstract syntax trees.
data AbstractSyntax
= Variable Identifier
-- There is no technical reason for the AST to forbid nullary applications and so forth.
-- However the parser rejects them to avoid confusing edge cases like `let x=in`,
-- so they're forbidden here too so that the syntax tree can't contain data
-- that the parser would refuse to accept.
--
-- As a matter of curiosity, here's why `let x=in` was syntactically valid:
-- 1. Parentheses in `let` statements are optional, infer them: `let x=()in()`.
-- 2. Insert optional whitespace: `let x = () in ()`.
-- 3. Nullary application expands to the identity function because
-- the identity function is the left identity of function application:
-- `let x=(\x.x) in \x.x`.
--
-- | n-ary function application: `(f x_1 x_2 ... x_n)`.
| Application (NonEmpty AbstractSyntax)
-- | Lambda abstraction over n variables: `(λx_1 x_2 ... x_n. e)`
| Abstraction (NonEmpty Identifier) AbstractSyntax
-- | Let expressions (syntactic sugar) binding `n` variables:
-- `let x_1 = e_1; x_2 = e_2; ... x_n = e_n`.
| Let (NonEmpty Definition) AbstractSyntax
type Definition = (Identifier, AbstractSyntax)
type Identifier = Text
makeBaseFunctor ''AbstractSyntax
-- I'm surprised this isn't in base somewhere.
unsnoc :: NonEmpty a -> ([a], a)
unsnoc = cata \case
NonEmptyF x' Nothing -> ([], x')
NonEmptyF x (Just (xs, x')) -> (x : xs, x')
data SyntaxType
-- | Ambiguous syntax is not necessarily finite and not guaranteed to consume any input.
= Ambiguous
-- | Block syntax is not necessarily finite but is guaranteed to consume input.
| Block
-- | Unambiguous syntax is finite and guaranteed to consume input.
| Finite
type Tagged a = (SyntaxType, a)
tag :: SyntaxType -> a -> Tagged a
tag = (,)
group :: Builder -> Builder
group x = "(" <> x <> ")"
-- | An unambiguous context has a marked beginning and end.
unambiguous :: Tagged Builder -> Builder
unambiguous (_, t) = t
-- | A final context has a marked end but no marked beginning,
-- so we provide a grouper when a beginning marker is necessary.
final :: Tagged Builder -> Builder
final (Ambiguous, t) = group t
final (_, t) = t
-- | An ambiguous context has neither a marked end nor marked beginning,
-- so we provide a grouper when an ending marker is necessary.
ambiguous :: Tagged Builder -> Builder
ambiguous (Finite, t) = t
ambiguous (_, t) = group t
instance TextShow AbstractSyntax where
showb = snd . cata \case
VariableF name -> tag Finite $ fromText name
ApplicationF (unsnoc -> (es, efinal)) -> tag Ambiguous $ foldr (\e es' -> ambiguous e <> " " <> es') (final efinal) es
AbstractionF names body -> tag Block $
let names' = fromText (T.intercalate " " $ toList names)
in "λ" <> names' <> ". " <> unambiguous body
LetF defs body -> tag Block $
let
showDef (name, val) = fromText name <> " = " <> unambiguous val
defs' = fromText (T.intercalate "; " $ map (toText . showDef) $ toList defs)
in "let " <> defs' <> " in " <> unambiguous body
instance Show AbstractSyntax where
show = T.unpack . showt

View File

@ -0,0 +1,7 @@
module LambdaCalculus.Syntax
( module LambdaCalculus.Syntax.Parser
, module LambdaCalculus.Syntax.Printer
) where
import LambdaCalculus.Syntax.Parser
import LambdaCalculus.Syntax.Printer

View File

@ -0,0 +1,66 @@
module LambdaCalculus.Syntax.Base
( Expr (..), ExprF (..), Def, DefF (..), VoidF, Text, NonEmpty (..)
, Parse, AST, ASTF, NonEmptyDefFs (..)
, pattern LetFP
, simplify
) where
import LambdaCalculus.Expression.Base
import Data.Functor.Foldable (embed, project)
import Data.List.NonEmpty (NonEmpty (..))
data Parse
-- | The abstract syntax tree reflects the structure of the externally-visible syntax.
--
-- It includes syntactic sugar, which allows multiple ways to express many constructions,
-- e.g. multiple definitions in a single let expression or multiple names bound by one abstraction.
type AST = Expr Parse
-- There is no technical reason that the AST can't allow nullary applications and so forth,
-- nor is there any technical reason that the parser couldn't parse them,
-- but the parser *does* reject them to avoid confusing edge cases like `let x=in`,
-- so they're forbidden here too so that the syntax tree can't contain data
--
-- that the parser would refuse to accept.
-- As a matter of curiosity, here's why `let x=in` was syntactically valid:
-- 1. Parentheses in `let` statements are optional, infer them: `let x=()in()`.
-- 2. Insert optional whitespace: `let x = () in ()`.
-- 3. Nullary application expands to the identity function because
-- the identity function is the left identity of function application:
-- `let x=(\x.x) in \x.x`.
type instance AppArgs Parse = NonEmpty AST
type instance AbsArgs Parse = NonEmpty Text
type instance LetArgs Parse = NonEmpty (Def Parse)
type instance XExpr Parse = VoidF AST
type ASTF = ExprF Parse
type instance AppArgsF Parse = NonEmpty
type instance LetArgsF Parse = NonEmptyDefFs
type instance XExprF Parse = VoidF
instance RecursivePhase Parse where
projectLetArgs = NonEmptyDefFs
embedLetArgs = getNonEmptyDefFs
newtype NonEmptyDefFs r = NonEmptyDefFs { getNonEmptyDefFs :: NonEmpty (Text, r) }
deriving (Eq, Functor, Foldable, Traversable, Show)
pattern LetFP :: NonEmpty (Text, r) -> r -> ASTF r
pattern LetFP ds e = LetF (NonEmptyDefFs ds) e
{-# COMPLETE VarF, AppF, AbsF, LetFP, ExprXF #-}
-- | Combine nested expressions into compound expressions when possible.
simplify :: AST -> AST
simplify = simplify' . embed . fmap simplify' . project
where
simplify' (App (App f es1) es2) = simplify' $ App f (es1 <> es2)
simplify' (App (Abs (nx :| ns) eb) (ex :| es)) = simplify' $ app' es $ Let ((nx, ex) :| []) $ abs' ns eb
where app' [] e = e
app' (ex2:es2) e = App e (ex2 :| es2)
abs' [] e = e
abs' (nx2:ns2) e = Abs (nx2 :| ns2) e
simplify' (Abs ns1 (Abs ns2 e)) = simplify' $ Abs (ns1 <> ns2) e
simplify' (Let ds1 (Let ds2 e)) = simplify' $ Let (ds1 <> ds2) e
simplify' e = e

View File

@ -1,10 +1,12 @@
module LambdaCalculus.Parser (parseAST, parseExpression) where module LambdaCalculus.Syntax.Parser
( ParseError
, parseAST
) where
import LambdaCalculus.Syntax.Base
import Data.List.NonEmpty (fromList) import Data.List.NonEmpty (fromList)
import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import LambdaCalculus.Expression (Expression, ast2expr)
import LambdaCalculus.Parser.AbstractSyntax
import Text.Parsec hiding (label, token) import Text.Parsec hiding (label, token)
import Text.Parsec qualified import Text.Parsec qualified
import Text.Parsec.Text (Parser) import Text.Parsec.Text (Parser)
@ -22,49 +24,49 @@ keywords = ["let", "in"]
keyword :: Text -> Parser () keyword :: Text -> Parser ()
keyword kwd = label (T.unpack kwd) $ do keyword kwd = label (T.unpack kwd) $ do
try do try do
string $ T.unpack kwd _ <- string $ T.unpack kwd
notFollowedBy letter notFollowedBy letter
spaces spaces
-- | An identifier is a sequence of letters which is not a keyword. -- | An identifier is a sequence of letters which is not a keyword.
identifier :: Parser Identifier identifier :: Parser Text
identifier = label "identifier" $ do identifier = label "identifier" $ do
notFollowedBy anyKeyword notFollowedBy anyKeyword
T.pack <$> (many1 letter <* spaces) T.pack <$> (many1 letter <* spaces)
where anyKeyword = choice $ map keyword keywords where anyKeyword = choice $ map keyword keywords
variable :: Parser AbstractSyntax variable :: Parser AST
variable = label "variable" $ Variable <$> identifier variable = label "variable" $ Var <$> identifier
many2 :: Parser a -> Parser [a] many1' :: Parser a -> Parser (NonEmpty a)
many2 p = (:) <$> p <*> many1 p many1' p = fromList <$> many1 p
grouping :: Parser AbstractSyntax many2 :: Parser a -> Parser (a, NonEmpty a)
many2 p = (,) <$> p <*> many1' p
grouping :: Parser AST
grouping = label "grouping" $ between (token '(') (token ')') expression grouping = label "grouping" $ between (token '(') (token ')') expression
application :: Parser AbstractSyntax application :: Parser AST
application = Application . fromList <$> many2 applicationTerm application = uncurry App <$> many2 applicationTerm
where applicationTerm = abstraction <|> let_ <|> grouping <|> variable where applicationTerm = abstraction <|> let_ <|> grouping <|> variable
abstraction :: Parser AbstractSyntax abstraction :: Parser AST
abstraction = label "lambda abstraction" $ Abstraction <$> between lambda (token '.') (fromList <$> many1 identifier) <*> expression abstraction = label "lambda abstraction" $ Abs <$> between lambda (token '.') (many1' identifier) <*> expression
where lambda = label "lambda" $ (char '\\' <|> char 'λ') *> spaces where lambda = label "lambda" $ (char '\\' <|> char 'λ') *> spaces
let_ :: Parser AbstractSyntax let_ :: Parser AST
let_ = Let <$> between (keyword "let") (keyword "in") (fromList <$> definitions) <*> expression let_ = Let <$> between (keyword "let") (keyword "in") (fromList <$> definitions) <*> expression
where where
definitions :: Parser [Definition] definitions :: Parser [Def Parse]
definitions = flip sepBy1 (token ';') do definitions = flip sepBy1 (token ';') do
name <- identifier name <- identifier
token '=' token '='
value <- expression value <- expression
pure (name, value) pure (name, value)
expression :: Parser AbstractSyntax expression :: Parser AST
expression = label "expression" $ abstraction <|> let_ <|> try application <|> grouping <|> variable expression = label "expression" $ abstraction <|> let_ <|> try application <|> grouping <|> variable
parseAST :: Text -> Either ParseError AbstractSyntax parseAST :: Text -> Either ParseError AST
parseAST = parse (spaces *> expression <* eof) "input" parseAST = parse (spaces *> expression <* eof) "input"
parseExpression :: Text -> Either ParseError Expression
parseExpression = fmap ast2expr . parseAST

View File

@ -0,0 +1,63 @@
module LambdaCalculus.Syntax.Printer (unparseAST) where
import LambdaCalculus.Syntax.Base
import Data.Functor.Base (NonEmptyF (NonEmptyF))
import Data.Functor.Foldable (cata)
import Data.List.NonEmpty (toList)
import Data.Text.Lazy (fromStrict, toStrict, intercalate, unwords)
import Data.Text.Lazy.Builder (Builder, fromText, fromLazyText, toLazyText)
import Prelude hiding (unwords)
-- I'm surprised this isn't in base somewhere.
unsnoc :: NonEmpty a -> ([a], a)
unsnoc = cata \case
NonEmptyF x' Nothing -> ([], x')
NonEmptyF x (Just (xs, x')) -> (x : xs, x')
data SyntaxType
-- | Ambiguous syntax is not necessarily finite and not guaranteed to consume any input.
= Ambiguous
-- | Block syntax is not necessarily finite but is guaranteed to consume input.
| Block
-- | Unambiguous syntax is finite and guaranteed to consume input.
| Finite
type Tagged a = (SyntaxType, a)
tag :: SyntaxType -> a -> Tagged a
tag = (,)
group :: Builder -> Builder
group x = "(" <> x <> ")"
-- | An unambiguous context has a marked beginning and end.
unambiguous :: Tagged Builder -> Builder
unambiguous (_, t) = t
-- | A final context has a marked end but no marked beginning,
-- so we provide a grouper when a beginning marker is necessary.
final :: Tagged Builder -> Builder
final (Ambiguous, t) = group t
final (_, t) = t
-- | An ambiguous context has neither a marked end nor marked beginning,
-- so we provide a grouper when an ending marker is necessary.
ambiguous :: Tagged Builder -> Builder
ambiguous (Finite, t) = t
ambiguous (_, t) = group t
-- | Turn an abstract syntax tree into the corresponding concrete syntax.
--
-- This is *not* a pretty-printer; it uses minimal whitespace.
unparseAST :: AST -> Text
unparseAST = toStrict . toLazyText . snd . cata \case
VarF name -> tag Finite $ fromText name
AppF ef (unsnoc -> (exs, efinal)) -> tag Ambiguous $ foldr (\e es' -> ambiguous e <> " " <> es') (final efinal) (ef : exs)
AbsF names body -> tag Block $
let names' = fromLazyText (unwords $ map fromStrict $ toList names)
in "λ" <> names' <> ". " <> unambiguous body
LetFP defs body -> tag Block $
let
unparseDef (name, val) = fromText name <> " = " <> unambiguous val
defs' = fromLazyText (intercalate "; " $ map (toLazyText . unparseDef) $ toList defs)
in "let " <> defs' <> " in " <> unambiguous body

View File

@ -1,3 +1,3 @@
resolver: lts-17.5 resolver: lts-17.6
packages: packages:
- . - .

View File

@ -6,7 +6,7 @@
packages: [] packages: []
snapshots: snapshots:
- completed: - completed:
size: 565266 size: 565712
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/6.yaml
sha256: 78e8ebabf11406261abbc95b44f240acf71802630b368888f6d758de7fc3a2f7 sha256: 4e5e581a709c88e3fe26a9ce8bf331435729bead762fb5c190064c6c5bb1b835
original: lts-17.5 original: lts-17.6

View File

@ -1,5 +1,5 @@
import LambdaCalculus import LambdaCalculus
import LambdaCalculus.Parser
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
@ -9,63 +9,64 @@ import Test.Tasty.HUnit
-- so the names for them are somewhat arbitrary. -- so the names for them are somewhat arbitrary.
-- This should evaluate to `y y`. -- This should evaluate to `y y`.
dfi :: Expression dfi :: EvalExpr
dfi = Application d (Application f i) dfi = App d (App f i)
where where
d = Abstraction "x" $ Application (Variable "x") (Variable "x") d = Abs "x" $ App (Var "x") (Var "x")
f = Abstraction "f" $ Application (Variable "f") (Application (Variable "f") (Variable "y")) f = Abs "f" $ App (Var "f") (App (Var "f") (Var "y"))
i = Abstraction "x" $ Variable "x" i = Abs "x" $ Var "x"
-- This should evalaute to `y`. -- This should evalaute to `y`.
ttttt :: Expression ttttt :: EvalExpr
ttttt = Application (Application (Application f t) (Abstraction "x" (Variable "x"))) (Variable "y") ttttt = App (App (App f t) (Abs "x" (Var "x"))) (Var "y")
where where
t = Abstraction "f" $ Abstraction "x" $ t = Abs "f" $ Abs "x" $
Application (Variable "f") (Application (Variable "f") (Variable "x")) App (Var "f") (App (Var "f") (Var "x"))
f = Abstraction "T" $ Abstraction "f" $ Abstraction "x" $ f = Abs "T" $ Abs "f" $ Abs "x" $
Application (Application App
(Application (Variable "T") (App
(Application (Variable "T") (App (Var "T")
(Application (Variable "T") (App (Var "T")
(Application (Variable "T") (App (Var "T")
(Variable "T"))))) (App (Var "T")
(Variable "f")) (Var "T")))))
(Variable "x") (Var "f"))
(Var "x")
-- | A simple divergent expression. -- | A simple divergent expression.
omega :: Expression omega :: EvalExpr
omega = Application x x omega = App x x
where x = Abstraction "x" (Application (Variable "x") (Variable "x")) where x = Abs "x" (App (Var "x") (Var "x"))
cc1 :: Expression cc1 :: EvalExpr
cc1 = Application (Variable "callcc") (Abstraction "k" (Application omega (Application (Variable "k") (Variable "z")))) cc1 = App (Var "callcc") (Abs "k" (App omega (App (Var "k") (Var "z"))))
cc2 :: Expression cc2 :: EvalExpr
cc2 = Application (Variable "y") (Application (Variable "callcc") (Abstraction "k" (Application (Variable "z") (Application (Variable "k") (Variable "x"))))) cc2 = App (Var "y") (App (Var "callcc") (Abs "k" (App (Var "z") (App (Var "k") (Var "x")))))
main :: IO () main :: IO ()
main = defaultMain $ main = defaultMain $
testGroup "Tests" testGroup "Tests"
[ testGroup "Evaluator tests" [ testGroup "Evaluator tests"
[ testCase "capture test 1: DFI" $ eval dfi @?= Application (Variable "y") (Variable "y") [ testCase "capture test 1: DFI" $ eval dfi @?= App (Var "y") (Var "y")
, testCase "capture test 2: ttttt" $ eval ttttt @?= Variable "y" , testCase "capture test 2: ttttt" $ eval ttttt @?= Var "y"
, testCase "invoking a continuation replaces the current continuation" $ eval cc1 @?= Variable "z" , testCase "invoking a continuation replaces the current continuation" $ eval cc1 @?= Var "z"
, testCase "callcc actually captures the current continuation" $ eval cc2 @?= Application (Variable "y") (Variable "x") , testCase "callcc actually captures the current continuation" $ eval cc2 @?= App (Var "y") (Var "x")
] ]
, testGroup "Parser tests" , testGroup "Parser tests"
[ testGroup "Unit tests" [ testGroup "Unit tests"
[ testCase "identity" $ parseExpression "\\x.x" @?= Right (Abstraction "x" $ Variable "x") [ testCase "identity" $ parseEval "\\x.x" @?= Right (Abs "x" $ Var "x")
, testCase "unary application" $ parseExpression "(x)" @?= Right (Variable "x") , testCase "unary application" $ parseEval "(x)" @?= Right (Var "x")
, testCase "application shorthand" $ parseExpression "a b c d" @?= Right (Application (Application (Application (Variable "a") (Variable "b")) (Variable "c")) (Variable "d")) , testCase "application shorthand" $ parseEval "a b c d" @?= Right (App (App (App (Var "a") (Var "b")) (Var "c")) (Var "d"))
, testCase "let" $ parseExpression "let x = \\y.y in x" @?= Right (Application (Abstraction "x" (Variable "x")) (Abstraction "y" (Variable "y"))) , testCase "let" $ parseEval "let x = \\y.y in x" @?= Right (App (Abs "x" (Var "x")) (Abs "y" (Var "y")))
, testCase "multi-let" $ parseExpression "let x = y; y = z in x y" @?= Right (Application (Abstraction "x" (Application (Abstraction "y" (Application (Variable "x") (Variable "y"))) (Variable "z"))) (Variable "y")) , testCase "multi-let" $ parseEval "let x = y; y = z in x y" @?= Right (App (Abs "x" (App (Abs "y" (App (Var "x") (Var "y"))) (Var "z"))) (Var "y"))
, testCase "ttttt" $ parseExpression "(\\T f x.(T (T (T (T T)))) f x) (\\f x.f (f x)) (\\x.x) y" , testCase "ttttt" $ parseEval "(\\T f x.(T (T (T (T T)))) f x) (\\f x.f (f x)) (\\x.x) y"
@?= Right ttttt @?= Right ttttt
, testGroup "Redundant whitespace" , testGroup "Redundant whitespace"
[ testCase "around variable" $ parseExpression " x " @?= Right (Variable "x") [ testCase "around variable" $ parseEval " x " @?= Right (Var "x")
, testCase "around lambda" $ parseExpression " \\ x y . x " @?= Right (Abstraction "x" $ Abstraction "y" $ Variable "x") , testCase "around lambda" $ parseEval " \\ x y . x " @?= Right (Abs "x" $ Abs "y" $ Var "x")
, testCase "around application" $ parseExpression " ( x (y ) ) " @?= Right (Application (Variable "x") (Variable "y")) , testCase "around application" $ parseEval " ( x (y ) ) " @?= Right (App (Var "x") (Var "y"))
, testCase "around let" $ parseExpression " let x=(y)in x " @?= Right (Application (Abstraction "x" (Variable "x")) (Variable "y")) , testCase "around let" $ parseEval " let x=(y)in x " @?= Right (App (Abs "x" (Var "x")) (Var "y"))
] ]
] ]
] ]