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
parent
4541f30f46
commit
a543981b67
GPG Key ID:
4B7F3DA9351E577C
@ -1,19 +1,22 @@
|
||||
module Main (main) where
|
||||
|
||||
import LambdaCalculus
|
||||
|
||||
import Control.Monad (forever)
|
||||
import Data.Text
|
||||
import Data.Text.IO qualified as TIO
|
||||
import LambdaCalculus (eval)
|
||||
import LambdaCalculus.Parser (parseExpression)
|
||||
import Data.Text (pack)
|
||||
import Data.Text.IO
|
||||
import Prelude hiding (putStr, putStrLn, getLine)
|
||||
import System.IO (hFlush, stdout)
|
||||
|
||||
prompt :: Text -> IO Text
|
||||
prompt text = do
|
||||
TIO.putStr text
|
||||
putStr text
|
||||
hFlush stdout
|
||||
TIO.getLine
|
||||
getLine
|
||||
|
||||
main :: IO ()
|
||||
main = forever $ parseExpression <$> prompt ">> " >>= \case
|
||||
Left parseError -> putStrLn $ "Parse error: " ++ show parseError
|
||||
Right expr -> print $ eval expr
|
||||
main = forever $ parseEval <$> prompt ">> " >>= \case
|
||||
Left parseError -> putStrLn $ "Parse error: " <> pack (show parseError)
|
||||
-- TODO: Support choosing which version to use at runtime.
|
||||
Right expr -> putStrLn $ unparseEval $ eval expr
|
||||
--Right expr -> mapM_ (putStrLn . unparseEval) $ snd $ traceEval expr
|
||||
|
||||
@ -1,156 +1,16 @@
|
||||
module LambdaCalculus
|
||||
( module LambdaCalculus.Expression
|
||||
, eval, traceEval
|
||||
( module LambdaCalculus.Evaluator
|
||||
, module LambdaCalculus.Expression
|
||||
, module LambdaCalculus.Syntax
|
||||
, parseEval, unparseEval
|
||||
) where
|
||||
|
||||
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, 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 (..))
|
||||
import LambdaCalculus.Evaluator
|
||||
import LambdaCalculus.Expression
|
||||
import LambdaCalculus.Syntax
|
||||
|
||||
-- | Free variables are variables which are present in an expression but not bound by any abstraction.
|
||||
freeVariables :: Expression -> HashSet Text
|
||||
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
|
||||
parseEval :: Text -> Either ParseError EvalExpr
|
||||
parseEval = fmap ast2eval . parseAST
|
||||
|
||||
-- | Bound variables are variables which are bound by any form of abstraction in an expression.
|
||||
boundVariables :: Expression -> HashSet Text
|
||||
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
|
||||
unparseEval :: EvalExpr -> Text
|
||||
unparseEval = unparseAST . simplify . eval2ast
|
||||
|
||||
@ -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
|
||||
@ -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 #-}
|
||||
@ -1,26 +1,26 @@
|
||||
module LambdaCalculus.Continuation
|
||||
module LambdaCalculus.Evaluator.Continuation
|
||||
( Continuation, continue, continue1
|
||||
, ContinuationCrumb (ApplyTo, AppliedTo, AbstractedOver)
|
||||
) where
|
||||
|
||||
import LambdaCalculus.Evaluator.Base
|
||||
|
||||
import Data.List (foldl')
|
||||
import Data.Text (Text)
|
||||
import LambdaCalculus.Expression
|
||||
|
||||
data ContinuationCrumb
|
||||
-- | 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 _)`
|
||||
| AppliedTo Expression
|
||||
| AppliedTo EvalExpr
|
||||
-- | The one-hole context of the body of a lambda abstraction: `(λx. _)`
|
||||
| AbstractedOver Text
|
||||
|
||||
type Continuation = [ContinuationCrumb]
|
||||
|
||||
continue1 :: Expression -> ContinuationCrumb -> Expression
|
||||
continue1 e (ApplyTo x) = Application e x
|
||||
continue1 e (AppliedTo x) = Application x e
|
||||
continue1 e (AbstractedOver name) = Abstraction name e
|
||||
continue1 :: EvalExpr -> ContinuationCrumb -> EvalExpr
|
||||
continue1 e (ApplyTo x) = App e x
|
||||
continue1 e (AppliedTo x) = App x e
|
||||
continue1 e (AbstractedOver name) = Abs name e
|
||||
|
||||
continue :: Expression -> Continuation -> Expression
|
||||
continue :: EvalExpr -> Continuation -> EvalExpr
|
||||
continue = foldl' continue1
|
||||
@ -1,96 +1,33 @@
|
||||
module LambdaCalculus.Expression
|
||||
( Expression (..), ExpressionF (..)
|
||||
, ast2expr, expr2ast
|
||||
, pattern Lets, pattern Abstractions, pattern Applications
|
||||
, viewLet, viewAbstraction, viewApplication
|
||||
( Expr (..), ExprF (..), DefF (..), VoidF, Text
|
||||
, Eval, EvalExpr, EvalX, EvalXF (..), Identity (..)
|
||||
, pattern AppFE, pattern Cont, pattern ContF
|
||||
, Parse, AST, ASTF, NonEmptyDefFs (..), NonEmpty (..), simplify
|
||||
, pattern LetFP
|
||||
, ast2eval, eval2ast
|
||||
) where
|
||||
|
||||
-- The definition of Expression is in its own file because:
|
||||
-- * Expression and AbstractSyntax should not be in the same file
|
||||
-- * 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 (ana, cata)
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
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
|
||||
= Variable Text
|
||||
-- | Function application: `(f x)`.
|
||||
| Application Expression Expression
|
||||
-- | Lambda abstraction: `(λx. e)`.
|
||||
| Abstraction Text Expression
|
||||
-- | 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.
|
||||
| Continuation Expression
|
||||
deriving Eq
|
||||
|
||||
makeBaseFunctor ''Expression
|
||||
|
||||
-- | Convert from an abstract syntax tree to an expression.
|
||||
ast2expr :: AbstractSyntax -> Expression
|
||||
ast2expr = cata \case
|
||||
AST.VariableF name -> Variable name
|
||||
AST.ApplicationF es -> case es of
|
||||
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
|
||||
import LambdaCalculus.Evaluator.Base
|
||||
import LambdaCalculus.Syntax.Base
|
||||
|
||||
import Data.Functor.Foldable (cata, hoist)
|
||||
import Data.List (foldl')
|
||||
import Data.List.NonEmpty (toList)
|
||||
|
||||
-- | Convert from an abstract syntax tree to an evaluator expression.
|
||||
ast2eval :: AST -> EvalExpr
|
||||
ast2eval = cata \case
|
||||
VarF name -> Var name
|
||||
AppF ef exs -> foldl' App ef $ toList exs
|
||||
AbsF ns e -> foldr Abs e $ toList ns
|
||||
LetF ds e ->
|
||||
let letExpr name val body' = App (Abs name body') val
|
||||
in foldr (uncurry letExpr) e $ getNonEmptyDefFs ds
|
||||
|
||||
-- | Convert from an evaluator expression to an abstract syntax tree.
|
||||
eval2ast :: EvalExpr -> AST
|
||||
eval2ast = hoist \case
|
||||
VarF name -> VarF name
|
||||
AppFE ef ex -> AppF ef (ex :| [])
|
||||
AbsF n e -> AbsF (n :| []) e
|
||||
ContF e -> AbsF ("!" :| []) e
|
||||
|
||||
@ -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.
|
||||
---
|
||||
@ -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
|
||||
@ -0,0 +1,7 @@
|
||||
module LambdaCalculus.Syntax
|
||||
( module LambdaCalculus.Syntax.Parser
|
||||
, module LambdaCalculus.Syntax.Printer
|
||||
) where
|
||||
|
||||
import LambdaCalculus.Syntax.Parser
|
||||
import LambdaCalculus.Syntax.Printer
|
||||
@ -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
|
||||
@ -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
|
||||
@ -1,3 +1,3 @@
|
||||
resolver: lts-17.5
|
||||
resolver: lts-17.6
|
||||
packages:
|
||||
- .
|
||||
|
||||
Loading…
Reference in New Issue