Lots of refactors using recursion-schemes, plus hacky code cleanup.
A side-effect of this refactoring was that I got `traceEval` for free!master
parent
1321c7f54e
commit
4541f30f46
|
@ -1,8 +1,8 @@
|
||||||
module Main where
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Monad (forever)
|
import Control.Monad (forever)
|
||||||
import Data.Text
|
import Data.Text
|
||||||
import qualified Data.Text.IO as TIO
|
import Data.Text.IO qualified as TIO
|
||||||
import LambdaCalculus (eval)
|
import LambdaCalculus (eval)
|
||||||
import LambdaCalculus.Parser (parseExpression)
|
import LambdaCalculus.Parser (parseExpression)
|
||||||
import System.IO (hFlush, stdout)
|
import System.IO (hFlush, stdout)
|
||||||
|
|
|
@ -14,16 +14,24 @@ extra-source-files:
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
- BlockArguments
|
- BlockArguments
|
||||||
|
- FlexibleContexts
|
||||||
- ImportQualifiedPost
|
- ImportQualifiedPost
|
||||||
- LambdaCase
|
- LambdaCase
|
||||||
- OverloadedStrings
|
- OverloadedStrings
|
||||||
- PatternSynonyms
|
- PatternSynonyms
|
||||||
- ViewPatterns
|
- ViewPatterns
|
||||||
|
# Required for use of recursion-schemes
|
||||||
|
- DeriveFoldable
|
||||||
|
- DeriveFunctor
|
||||||
|
- DeriveTraversable
|
||||||
|
- TemplateHaskell
|
||||||
|
- TypeFamilies
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >= 4.14 && < 5
|
- base >= 4.14 && < 5
|
||||||
- mtl >= 2.2 && < 3
|
- mtl >= 2.2 && < 3
|
||||||
- parsec >= 3.1 && < 4
|
- parsec >= 3.1 && < 4
|
||||||
|
- recursion-schemes >= 5.2 && < 6
|
||||||
- text >= 1.2 && < 2
|
- text >= 1.2 && < 2
|
||||||
- text-show >= 3.9 && < 4
|
- text-show >= 3.9 && < 4
|
||||||
- unordered-containers >= 0.2.13 && < 0.3
|
- unordered-containers >= 0.2.13 && < 0.3
|
||||||
|
@ -42,6 +50,7 @@ library:
|
||||||
# Less stupid warnings, but I still don't care
|
# Less stupid warnings, but I still don't care
|
||||||
- -Wno-unused-do-bind
|
- -Wno-unused-do-bind
|
||||||
- -Wno-all-missed-specialisations
|
- -Wno-all-missed-specialisations
|
||||||
|
- -Wno-missing-local-signatures
|
||||||
# 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
|
||||||
|
|
|
@ -0,0 +1,26 @@
|
||||||
|
module Data.Stream (Stream (Cons), filter, fromList) where
|
||||||
|
|
||||||
|
import Data.Functor.Foldable (Base, Corecursive, Recursive, embed, project, ana)
|
||||||
|
import Prelude hiding (filter, head, tail)
|
||||||
|
|
||||||
|
data Stream a = Cons a (Stream a)
|
||||||
|
|
||||||
|
type instance Base (Stream a) = (,) a
|
||||||
|
|
||||||
|
instance Recursive (Stream a) where
|
||||||
|
project (Cons x xs) = (x, xs)
|
||||||
|
|
||||||
|
instance Corecursive (Stream a) where
|
||||||
|
embed (x, xs) = Cons x xs
|
||||||
|
|
||||||
|
filter :: (a -> Bool) -> Stream a -> Stream a
|
||||||
|
filter p = ana \case
|
||||||
|
Cons x xs
|
||||||
|
| p x -> (x, xs)
|
||||||
|
| otherwise -> project xs
|
||||||
|
|
||||||
|
fromList :: [a] -> Stream a
|
||||||
|
fromList = ana coalg
|
||||||
|
where
|
||||||
|
coalg (x : xs) = (x, xs)
|
||||||
|
coalg [] = error "Attempted to turn finite list into stream"
|
|
@ -1,106 +1,156 @@
|
||||||
module LambdaCalculus
|
module LambdaCalculus
|
||||||
( module LambdaCalculus.Expression
|
( module LambdaCalculus.Expression
|
||||||
, eval
|
, eval, traceEval
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.State (State, evalState, modify', state, put, gets)
|
import Control.Monad.Except (MonadError, ExceptT, throwError, runExceptT)
|
||||||
import Data.List (find)
|
import Control.Monad.State (MonadState, State, evalState, modify', state, put, gets)
|
||||||
import Data.Maybe (fromJust)
|
import Control.Monad.Writer (runWriterT, tell)
|
||||||
|
import Data.Functor.Foldable (cata, para, project, embed)
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.HashSet qualified as HS
|
import Data.HashSet qualified as HS
|
||||||
|
import Data.Stream (Stream)
|
||||||
|
import Data.Stream qualified as S
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
|
import Data.Void (Void, absurd)
|
||||||
import LambdaCalculus.Continuation
|
import LambdaCalculus.Continuation
|
||||||
import LambdaCalculus.Expression (Expression (..), foldExpr)
|
import LambdaCalculus.Expression (Expression (..), ExpressionF (..))
|
||||||
|
|
||||||
-- | Free variables are variables which are present in an expression but not bound by any abstraction.
|
-- | Free variables are variables which are present in an expression but not bound by any abstraction.
|
||||||
freeVariables :: Expression -> HashSet Text
|
freeVariables :: Expression -> HashSet Text
|
||||||
freeVariables = foldExpr HS.singleton HS.union HS.delete
|
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
|
||||||
|
|
||||||
-- FIXME
|
-- | Bound variables are variables which are bound by any form of abstraction in an expression.
|
||||||
quickHack :: Expression -> Expression
|
boundVariables :: Expression -> HashSet Text
|
||||||
quickHack (Continuation name body) = Abstraction name body
|
boundVariables = cata \case
|
||||||
quickHack e = e
|
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.
|
-- | Substitution is the process of replacing all free occurrences of a variable in one expression with another expression.
|
||||||
substitute :: Text -> Expression -> Expression -> Expression
|
substitute :: Text -> Expression -> Expression -> Expression
|
||||||
substitute var1 value unmodified@(Variable var2)
|
substitute var val = unsafeSubstitute var val . alphaConvert (usedVariables val)
|
||||||
| var1 == var2 = value
|
|
||||||
| otherwise = unmodified
|
-- | Rename the bound variables in `e` so they do not overlap any variables used in `ctx`.
|
||||||
substitute var value (Application ef ex)
|
--
|
||||||
= Application (substitute var value ef) (substitute var value ex)
|
-- This is used as part of substitution when substituting `val` with free variables `ctx` into `e`,
|
||||||
substitute var1 value unmodified@(quickHack -> Abstraction var2 body)
|
-- because it prevents any of the binders in `e` from accidentally capturing a free variable in `ctx`.
|
||||||
| var1 == var2 = unmodified
|
alphaConvert :: HashSet Text -> Expression -> Expression
|
||||||
| otherwise = constructor var2' $ substitute var1 value $ alphaConvert var2 var2' body
|
alphaConvert ctx e_ = evalState (rename e_) $ freshVariables $ HS.union (usedVariables e_) ctx
|
||||||
where
|
where
|
||||||
constructor = case unmodified of
|
rename :: Expression -> State (Stream Text) Expression
|
||||||
Abstraction _ _ -> Abstraction
|
rename = cata \case
|
||||||
Continuation _ _ -> Continuation
|
VariableF var -> pure $ Variable var
|
||||||
_ -> error "impossible"
|
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
|
||||||
|
|
||||||
var2' :: Text
|
-- | Substitution with the assumption that no free variables in the value are bound in the expression.
|
||||||
var2' = escapeName (freeVariables value) var2
|
unsafeSubstitute :: Text -> Expression -> Expression -> Expression
|
||||||
|
unsafeSubstitute var val = para \case
|
||||||
alphaConvert :: Text -> Text -> Expression -> Expression
|
e'
|
||||||
alphaConvert oldName newName expr = substitute oldName (Variable newName) expr
|
| VariableF var2 <- e', var == var2 -> val
|
||||||
-- | Generate a new name which isn't present in the set, based on the old name.
|
| ApplicationF (_, ef) (_, ex) <- e' -> Application ef ex
|
||||||
escapeName :: HashSet Text -> Text -> Text
|
| ContinuationF (_, e) <- e', var /= "!" -> Continuation e
|
||||||
escapeName env name = fromJust $ find (not . free) names
|
| AbstractionF var2 (_, e) <- e', var /= var2 -> Abstraction var2 e
|
||||||
where names :: [Text]
|
| otherwise -> embed $ fmap fst e'
|
||||||
names = name : map (`T.snoc` '\'') names
|
|
||||||
|
|
||||||
free :: Text -> Bool
|
|
||||||
free = (`HS.member` env)
|
|
||||||
substitute _ _ _ = error "impossible"
|
|
||||||
|
|
||||||
type EvaluatorM a = State Continuation a
|
|
||||||
type Evaluator = Expression -> EvaluatorM Expression
|
|
||||||
|
|
||||||
isReducible :: Expression -> Bool
|
isReducible :: Expression -> Bool
|
||||||
isReducible (Application (quickHack -> (Abstraction _ _)) _) = True
|
isReducible = snd . cata \case
|
||||||
isReducible (Application (Variable "callcc") _) = True
|
ApplicationF ctr args -> eliminator ctr [args]
|
||||||
isReducible (Application ef ex) = isReducible ef || isReducible ex
|
VariableF "callcc" -> constructor
|
||||||
isReducible _ = False
|
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 :: ContinuationCrumb -> EvaluatorM ()
|
push :: MonadState Continuation m => ContinuationCrumb -> m ()
|
||||||
push c = modify' (c :)
|
push c = modify' (c :)
|
||||||
|
|
||||||
pop :: EvaluatorM (Maybe ContinuationCrumb)
|
pop :: MonadState Continuation m => m (Maybe ContinuationCrumb)
|
||||||
pop = state \case
|
pop = state \case
|
||||||
[] -> (Nothing, [])
|
[] -> (Nothing, [])
|
||||||
(crumb:k) -> (Just crumb, k)
|
(crumb:k) -> (Just crumb, k)
|
||||||
|
|
||||||
ret :: Expression -> EvaluatorM Expression
|
ret :: (MonadError Expression m, MonadState Continuation m) => Expression -> m Expression
|
||||||
ret e = pop >>= maybe (pure e) (evaluator . continue1 e)
|
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.
|
-- | A call-by-value expression evaluator.
|
||||||
evaluator :: Evaluator
|
evaluatorStep :: (MonadError Expression m, MonadState Continuation m) => Expression -> m Expression
|
||||||
evaluator unmodified@(Application ef ex)
|
evaluatorStep = \case
|
||||||
-- First reduce the argument...
|
unmodified@(Application ef ex)
|
||||||
| isReducible ex = do
|
-- First reduce the argument...
|
||||||
push (AppliedTo ef)
|
| isReducible ex -> do
|
||||||
evaluator ex
|
push (AppliedTo ef)
|
||||||
-- then reduce the function...
|
pure ex
|
||||||
| isReducible ef = do
|
-- then reduce the function...
|
||||||
push (ApplyTo ex)
|
| isReducible ef -> do
|
||||||
evaluator ef
|
push (ApplyTo ex)
|
||||||
| otherwise = case ef of
|
pure ef
|
||||||
-- perform beta reduction if possible...
|
| otherwise -> case ef of
|
||||||
Abstraction name body ->
|
-- perform beta reduction if possible...
|
||||||
evaluator $ substitute name ex body
|
Abstraction name body ->
|
||||||
-- perform continuation calls if possible...
|
pure $ substitute name ex body
|
||||||
Continuation name body -> do
|
-- perform continuation calls if possible...
|
||||||
put []
|
Continuation body -> do
|
||||||
evaluator $ substitute name ex body
|
put []
|
||||||
-- capture the current continuation if requested...
|
pure $ substitute "!" ex body
|
||||||
Variable "callcc" -> do
|
-- capture the current continuation if requested...
|
||||||
-- Don't worry about variable capture here for now.
|
Variable "callcc" -> do
|
||||||
k <- gets $ continue (Variable "!")
|
-- Don't worry about variable capture here for now.
|
||||||
evaluator (Application ex (Continuation "!" k))
|
k <- gets $ continue (Variable "!")
|
||||||
-- otherwise the value is irreducible and we can continue evaluation.
|
pure $ Application ex (Continuation k)
|
||||||
_ -> ret unmodified
|
-- otherwise the value is irreducible and we can continue evaluation.
|
||||||
-- Neither abstractions nor variables are reducible.
|
_ -> ret unmodified
|
||||||
evaluator e = ret e
|
-- Neither abstractions nor variables are reducible.
|
||||||
|
e -> ret e
|
||||||
|
|
||||||
eval :: Expression -> Expression
|
eval :: Expression -> Expression
|
||||||
eval = flip evalState [] . evaluator
|
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
|
||||||
|
|
|
@ -1,9 +1,8 @@
|
||||||
module LambdaCalculus.Expression
|
module LambdaCalculus.Expression
|
||||||
( Expression (..), foldExpr
|
( Expression (..), ExpressionF (..)
|
||||||
, ast2expr, expr2ast
|
, ast2expr, expr2ast
|
||||||
, pattern Lets, pattern Abstractions, pattern Applications
|
, pattern Lets, pattern Abstractions, pattern Applications
|
||||||
, viewLet, viewAbstraction, viewApplication
|
, viewLet, viewAbstraction, viewApplication
|
||||||
, basicShow
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- The definition of Expression is in its own file because:
|
-- The definition of Expression is in its own file because:
|
||||||
|
@ -14,13 +13,16 @@ module LambdaCalculus.Expression
|
||||||
-- * I don't want to clutter the module focusing on the actual evaluation
|
-- * I don't want to clutter the module focusing on the actual evaluation
|
||||||
-- with all of these irrelevant conversion operators.
|
-- with all of these irrelevant conversion operators.
|
||||||
|
|
||||||
import Data.Bifunctor (first, second)
|
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.List.NonEmpty (NonEmpty ((:|)), fromList, toList)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import LambdaCalculus.Parser.AbstractSyntax (AbstractSyntax)
|
import LambdaCalculus.Parser.AbstractSyntax (AbstractSyntax)
|
||||||
import LambdaCalculus.Parser.AbstractSyntax qualified as AST
|
import LambdaCalculus.Parser.AbstractSyntax qualified as AST
|
||||||
import TextShow (Builder, fromText, TextShow, showb, showt)
|
import TextShow (TextShow, showb, showt)
|
||||||
|
|
||||||
data Expression
|
data Expression
|
||||||
= Variable Text
|
= Variable Text
|
||||||
|
@ -33,37 +35,22 @@ data Expression
|
||||||
-- deleting the current continuation.
|
-- deleting the current continuation.
|
||||||
--
|
--
|
||||||
-- Continuations do not have any corresponding surface-level syntax.
|
-- Continuations do not have any corresponding surface-level syntax.
|
||||||
| Continuation Text Expression
|
| Continuation Expression
|
||||||
deriving Eq
|
deriving Eq
|
||||||
|
|
||||||
foldExpr :: (Text -> a) -> (a -> a -> a) -> (Text -> a -> a) -> Expression -> a
|
makeBaseFunctor ''Expression
|
||||||
foldExpr varf appf absf = foldExpr'
|
|
||||||
where
|
|
||||||
foldExpr' (Variable name) = varf name
|
|
||||||
foldExpr' (Application ef ex) = appf (foldExpr' ef) (foldExpr' ex)
|
|
||||||
foldExpr' (Abstraction name body) = absf name (foldExpr' body)
|
|
||||||
-- This isn't technically correct, but it's good enough for every place I use this.
|
|
||||||
-- I'll figure out a proper solution later, or possibly just rip out this function.
|
|
||||||
foldExpr' (Continuation name body) = absf name (foldExpr' body)
|
|
||||||
|
|
||||||
-- | A naive implementation of 'show', which does not take advantage of any syntactic sugar
|
|
||||||
-- and always emits optional parentheses.
|
|
||||||
basicShow :: Expression -> Builder
|
|
||||||
basicShow (Variable var) = fromText var
|
|
||||||
basicShow (Application ef ex) = "(" <> showb ef <> " " <> showb ex <> ")"
|
|
||||||
basicShow (Abstraction var body) = "(λ" <> fromText var <> ". " <> showb body <> ")"
|
|
||||||
basicShow (Continuation var body) = "(Λ" <> fromText var <> ". " <> showb body <> ")"
|
|
||||||
|
|
||||||
-- | Convert from an abstract syntax tree to an expression.
|
-- | Convert from an abstract syntax tree to an expression.
|
||||||
ast2expr :: AbstractSyntax -> Expression
|
ast2expr :: AbstractSyntax -> Expression
|
||||||
ast2expr (AST.Variable name) = Variable name
|
ast2expr = cata \case
|
||||||
ast2expr (AST.Application (x :| [])) = ast2expr x
|
AST.VariableF name -> Variable name
|
||||||
ast2expr (AST.Application xs) = foldl1 Application $ map ast2expr (toList xs)
|
AST.ApplicationF es -> case es of
|
||||||
ast2expr (AST.Abstraction names body) = foldr Abstraction (ast2expr body) names
|
x :| [] -> x
|
||||||
ast2expr (AST.Let defs body) = foldr (uncurry letExpr . second ast2expr) (ast2expr body) defs
|
xs -> foldl1' Application (toList xs)
|
||||||
where
|
AST.AbstractionF names body -> foldr Abstraction body (toList names)
|
||||||
letExpr :: Text -> Expression -> Expression -> Expression
|
AST.LetF defs body ->
|
||||||
letExpr name val body' = Application (Abstraction name body') val
|
let letExpr name val body' = Application (Abstraction name body') val
|
||||||
|
in foldr (uncurry letExpr) body defs
|
||||||
|
|
||||||
-- | View nested applications of abstractions as a list.
|
-- | View nested applications of abstractions as a list.
|
||||||
pattern Lets :: [(Text, Expression)] -> Expression -> Expression
|
pattern Lets :: [(Text, Expression)] -> Expression -> Expression
|
||||||
|
@ -88,18 +75,19 @@ pattern Applications exprs <- (viewApplication -> exprs@(_:_:_))
|
||||||
{-# COMPLETE Abstractions, Applications, Continuation, Variable :: Expression #-}
|
{-# COMPLETE Abstractions, Applications, Continuation, Variable :: Expression #-}
|
||||||
|
|
||||||
viewApplication :: Expression -> [Expression]
|
viewApplication :: Expression -> [Expression]
|
||||||
viewApplication (Application ef ex) = ex : viewApplication ef
|
viewApplication (Application ef ex) = viewApplication ef ++ [ex]
|
||||||
viewApplication x = [x]
|
viewApplication x = [x]
|
||||||
|
|
||||||
-- | Convert from an expression to an abstract syntax tree.
|
-- | Convert from an expression to an abstract syntax tree.
|
||||||
--
|
--
|
||||||
-- This function will use let, and applications and abstractions of multiple values when possible.
|
-- This function will use let, and applications and abstractions of multiple values when possible.
|
||||||
expr2ast :: Expression -> AbstractSyntax
|
expr2ast :: Expression -> AbstractSyntax
|
||||||
expr2ast (Lets defs body) = AST.Let (fromList $ map (second expr2ast) defs) $ expr2ast body
|
expr2ast = ana \case
|
||||||
expr2ast (Abstractions names body) = AST.Abstraction (fromList names) $ expr2ast body
|
Lets defs body -> AST.LetF (fromList defs) body
|
||||||
expr2ast (Applications exprs) = AST.Application $ fromList $ map expr2ast $ reverse exprs
|
Abstractions names body -> AST.AbstractionF (fromList names) body
|
||||||
expr2ast (Variable name) = AST.Variable name
|
Applications exprs -> AST.ApplicationF $ fromList exprs
|
||||||
expr2ast (Continuation _ body) = AST.Abstraction ("!" :| []) (expr2ast body)
|
Continuation body -> AST.AbstractionF ("!" :| []) body
|
||||||
|
Variable name -> AST.VariableF name
|
||||||
|
|
||||||
instance TextShow Expression where
|
instance TextShow Expression where
|
||||||
showb = showb . expr2ast
|
showb = showb . expr2ast
|
||||||
|
|
|
@ -1,9 +1,11 @@
|
||||||
module LambdaCalculus.Parser.AbstractSyntax
|
module LambdaCalculus.Parser.AbstractSyntax
|
||||||
( AbstractSyntax (..), Definition, Identifier
|
( AbstractSyntax (..), AbstractSyntaxF (..), Definition, Identifier
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Bifunctor (first)
|
import Data.Functor.Base (NonEmptyF (NonEmptyF))
|
||||||
import Data.List.NonEmpty (NonEmpty ((:|)), fromList, toList)
|
import Data.Functor.Foldable (cata)
|
||||||
|
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||||
|
import Data.List.NonEmpty (NonEmpty, toList)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import TextShow (Builder, TextShow, showb, showt, toText, fromText)
|
import TextShow (Builder, TextShow, showb, showt, toText, fromText)
|
||||||
|
@ -38,36 +40,57 @@ data AbstractSyntax
|
||||||
type Definition = (Identifier, AbstractSyntax)
|
type Definition = (Identifier, AbstractSyntax)
|
||||||
type Identifier = Text
|
type Identifier = Text
|
||||||
|
|
||||||
|
makeBaseFunctor ''AbstractSyntax
|
||||||
|
|
||||||
-- I'm surprised this isn't in base somewhere.
|
-- I'm surprised this isn't in base somewhere.
|
||||||
unsnoc :: NonEmpty a -> ([a], a)
|
unsnoc :: NonEmpty a -> ([a], a)
|
||||||
unsnoc (x :| []) = ([], x)
|
unsnoc = cata \case
|
||||||
unsnoc (x :| xs) = first (x :) (unsnoc (fromList xs))
|
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
|
instance TextShow AbstractSyntax where
|
||||||
showb = unambiguous
|
showb = snd . cata \case
|
||||||
where
|
VariableF name -> tag Finite $ fromText name
|
||||||
-- Parentheses are often optional to the parser, but not in every context.
|
ApplicationF (unsnoc -> (es, efinal)) -> tag Ambiguous $ foldr (\e es' -> ambiguous e <> " " <> es') (final efinal) es
|
||||||
-- The `unambigous` printer is used in contexts where parentheses are optional, and does not include them;
|
AbstractionF names body -> tag Block $
|
||||||
-- the `ambiguous` printer is used when omitting parentheses could result in an incorrect parse.
|
let names' = fromText (T.intercalate " " $ toList names)
|
||||||
unambiguous, ambiguous :: AbstractSyntax -> Builder
|
in "λ" <> names' <> ". " <> unambiguous body
|
||||||
unambiguous (Variable name) = fromText name
|
LetF defs body -> tag Block $
|
||||||
unambiguous (Application (unsnoc -> (es, final))) = foldr (\e es' -> ambiguous e <> " " <> es') final' es
|
let
|
||||||
where
|
showDef (name, val) = fromText name <> " = " <> unambiguous val
|
||||||
final' = case final of
|
defs' = fromText (T.intercalate "; " $ map (toText . showDef) $ toList defs)
|
||||||
Application _ -> ambiguous final
|
in "let " <> defs' <> " in " <> unambiguous body
|
||||||
_ -> unambiguous final
|
|
||||||
unambiguous (Abstraction names body) = "λ" <> names' <> ". " <> unambiguous body
|
|
||||||
where names' = fromText (T.intercalate " " $ toList names)
|
|
||||||
unambiguous (Let defs body) = "let " <> defs' <> " in " <> unambiguous body
|
|
||||||
where
|
|
||||||
defs' = fromText (T.intercalate "; " $ map (toText . showDef) $ toList defs)
|
|
||||||
|
|
||||||
showDef :: Definition -> Builder
|
|
||||||
showDef (name, val) = fromText name <> " = " <> unambiguous val
|
|
||||||
|
|
||||||
-- | Adds a grouper if omitting it could result in ambiguous syntax.)
|
|
||||||
ambiguous e@(Variable _) = unambiguous e
|
|
||||||
ambiguous e = "(" <> unambiguous e <> ")"
|
|
||||||
|
|
||||||
instance Show AbstractSyntax where
|
instance Show AbstractSyntax where
|
||||||
show = T.unpack . showt
|
show = T.unpack . showt
|
||||||
|
|
Loading…
Reference in New Issue