77 lines
3.4 KiB
Haskell
77 lines
3.4 KiB
Haskell
module LambdaCalculus.Representation.AbstractSyntax where
|
|
|
|
import Control.Comonad.Cofree (Cofree ((:<)))
|
|
import Data.Functor.Foldable (cata, histo)
|
|
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
|
import Data.List (foldl1')
|
|
import LambdaCalculus.Combinators (i)
|
|
import LambdaCalculus.Representation
|
|
import qualified LambdaCalculus.Representation.Standard as Std
|
|
|
|
data Expression = Variable String
|
|
| Abstraction [String] Expression
|
|
| Application [Expression]
|
|
-- | `let name = value in body`
|
|
| Let String Expression Expression
|
|
|
|
makeBaseFunctor ''Expression
|
|
|
|
instance Show Expression where
|
|
show = histo \case
|
|
VariableF name -> name
|
|
AbstractionF names (body :< _) -> "λ" ++ unwords names ++ ". " ++ body
|
|
-- TODO: this is a weird implementation of re-grouping variables,
|
|
-- to the degree that explicit recursion would probably be more clear.
|
|
-- Clean this up!
|
|
ApplicationF exprs -> unwords $ mapExceptLast regroup regroupApplication exprs
|
|
LetF name (value :< _) (body :< _)
|
|
-> "let " ++ name ++ " = " ++ value ++ " in " ++ body
|
|
where regroup (expr :< AbstractionF _ _) = group expr
|
|
regroup (expr :< LetF _ _ _) = group expr
|
|
regroup expr = regroupApplication expr
|
|
|
|
regroupApplication (expr :< ApplicationF _) = group expr
|
|
regroupApplication (expr :< _) = expr
|
|
|
|
group str = "(" ++ str ++ ")"
|
|
|
|
-- | Map the first function to all but the last element of the list,
|
|
-- and the last function to only the last element.
|
|
mapExceptLast :: (a -> b) -> (a -> b) -> [a] -> [b]
|
|
-- TODO: express this as a paramorphism
|
|
mapExceptLast _ _ [] = []
|
|
mapExceptLast _ fLast [x] = [fLast x]
|
|
mapExceptLast f fLast (x:xs) = f x : mapExceptLast f fLast xs
|
|
|
|
instance IsExpr Expression where
|
|
toStandard = cata \case
|
|
VariableF name -> Std.Variable name
|
|
-- We could technically just use `foldl' Std.Application i exprs`,
|
|
-- since that's the justification for allowing non-binary applications in the first place,
|
|
-- but we want expressions using only binary applications
|
|
-- to still generate the same expression,
|
|
-- not just beta-equivalent expressions.
|
|
ApplicationF [] -> i
|
|
ApplicationF [expr] -> expr
|
|
ApplicationF exprs -> foldl1' Std.Application exprs
|
|
AbstractionF names body -> foldr Std.Abstraction body names
|
|
LetF name value body -> Std.Application (Std.Abstraction name body) value
|
|
|
|
-- Again with the intent of generating the canonical form for this representation,
|
|
-- we want to convert all left-nested applications into a list application;
|
|
-- similarly, we convert nested abstractions into a list of names,
|
|
-- and abstractions into `let`s when applicable.
|
|
fromStandard = histo \case
|
|
Std.VariableF name -> Variable name
|
|
-- `(\x. e) N` --> `let x = N in e`.
|
|
Std.ApplicationF (_ :< Std.AbstractionF name (body :< _)) (value :< _)
|
|
-> Let name value body
|
|
Std.ApplicationF (Application exprs :< _) (xe :< _)
|
|
-> Application $ exprs ++ [xe]
|
|
Std.ApplicationF (fe :< _) (xe :< _)
|
|
-> Application [fe, xe]
|
|
Std.AbstractionF name (Abstraction names body :< _)
|
|
-> Abstraction (name : names) body
|
|
Std.AbstractionF name (body :< _)
|
|
-> Abstraction [name] body
|