Cleaned up the code, removed dep on recursion-schemes.

app/Main.hs

@@ -1,10 +1,10 @@
+{-# LANGUAGE BlockArguments, LambdaCase #-}
 module Main where
 
 import Control.Monad (forever)
 import System.IO (hFlush, stdout)
-import Text.Parsec (parse)
 import UntypedLambdaCalculus (eval)
-import UntypedLambdaCalculus.Parser (expr)
+import UntypedLambdaCalculus.Parser (parseExpr)
 
 prompt :: String -> IO String
 prompt text = do
@@ -13,8 +13,6 @@ prompt text = do
   getLine
 
 main :: IO ()
-main = forever $ do
+main = forever $ parseExpr "stdin" <$> prompt ">> " >>= \case
-  input <- expr "stdin" <$> prompt ">> "
+  Left parseError -> putStrLn $ "Parse error: " ++ show parseError
-  case input of
+  Right expr -> print $ eval expr
-    Left parseError -> putStrLn $ "Parse error: " ++ show parseError
-    Right ast -> print $ eval ast

package.yaml

@@ -16,8 +16,6 @@ dependencies:
 - base >= 4.7 && < 5
 - mtl >= 2.2 && < 3
 - parsec >= 3.1 && < 4
-- recursion-schemes >= 5.1 && < 6
-- unordered-containers >= 0.2.10 && < 0.3
 - transformers >= 0.5.6 && < 0.6
 
 library:

src/Data/Fin.hs

@@ -1,56 +1,48 @@
-{-# LANGUAGE TypeFamilies, GADTs, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE GADTs, DataKinds, KindSignatures #-}
-module Data.Fin (Fin (Zero, Succ), toInt, pred, finRemove) where
+module Data.Fin (Fin (FZ, FS), toInt, coerceFin, pred, extract) where
 
-import Data.Functor.Foldable (Base, Recursive, project, cata)
+import Data.Nat (Nat (S))
-import Data.Injection (Injection, inject)
-import Data.Type.Nat (Nat, Zero, Succ, GTorEQ)
 import Prelude hiding (pred)
 import Unsafe.Coerce (unsafeCoerce)
 
-data Fin n where
+-- | A type with `n` inhabitants, or alternatively,
+-- | a natural number less than the upper bound parameter.
+data Fin :: Nat -> * where
   -- Fin Zero is uninhabited. Fin (Succ Zero) has one inhabitant.
-  Zero :: Nat n => Fin (Succ n)
+  FZ :: Fin ('S n)
-  Succ :: Nat n => Fin n -> Fin (Succ n)
+  FS :: Fin n -> Fin ('S n)
 
-type instance Base (Fin n) = Maybe
+instance Eq (Fin n) where
+  FZ   == FZ   = True
+  FS n == FS m = n == m
+  _    == _    = False
 
-instance (Nat n) => Injection (Fin n) (Fin (Succ n)) where
+instance Ord (Fin n) where
-  inject Zero = Zero
+  FZ   `compare` FZ   = EQ
-  inject (Succ n) = Succ (inject n)
+  FS _ `compare` FZ   = GT
+  FZ   `compare` FS _ = LT
+  FS n `compare` FS m = n `compare` m
 
-instance (Nat n) => Recursive (Fin n) where
+toInt :: Fin n -> Int
-  project Zero     = Nothing
+toInt FZ     = 0
-  project (Succ n) = Just $ inject n
+toInt (FS n) = 1 + toInt n
 
-instance (Nat n) => Eq (Fin n) where
+instance Show (Fin n) where
-  Zero == Zero = True
-  Succ n == Succ m = n == m
-  _ == _ = False
-
-instance Nat n => Ord (Fin n) where
-  compare Zero     Zero     = EQ
-  compare (Succ n) Zero     = GT
-  compare Zero     (Succ n) = LT
-  compare (Succ n) (Succ m) = compare n m
-
-toInt :: Nat n => Fin n -> Int
-toInt = cata alg
-  where alg Nothing  = 0
-        alg (Just n) = n + 1
-
-instance (Nat n) => Show (Fin n) where
   show = show . toInt
 
-pred :: Nat n => Fin (Succ n) -> Maybe (Fin n)
+coerceFin :: Fin n -> Fin ('S n)
-pred Zero     = Nothing
+coerceFin FZ     = FZ
-pred (Succ n) = Just n
+coerceFin (FS n) = FS $ coerceFin n
 
--- | Remove an element from a `Fin`'s domain.
+pred :: Fin ('S n) -> Maybe (Fin n)
--- | Like a generalized `pred`, only you can remove elements other than `Zero`.
+pred FZ     = Nothing
-finRemove :: Nat n => Fin (Succ n) -> Fin (Succ n) -> Maybe (Fin n)
+pred (FS n) = Just n
-finRemove n m
+
+-- | Match against an element in `Fin`, removing it from its domain.
+extract :: Fin ('S n) -> Fin ('S n) -> Maybe (Fin n)
+extract n m
   | n == m = Nothing
   | n >  m = pred n
   -- I am convinced it is not possible to prove to the compiler
   -- that this function is valid without `unsafeCoerce`.
-  | n <  m = Just $ unsafeCoerce n
+  | otherwise = Just $ unsafeCoerce n

src/Data/Injection.hs

@@ -1,11 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-module Data.Injection (Injection, inject) where
-
-class Injection a b where
-  inject :: a -> b
-
-instance Injection a a where
-  inject = id
-
-instance Injection a (Maybe a) where
-  inject = Just

src/Data/Nat.hs

@@ -0,0 +1,3 @@
+module Data.Nat (Nat (Z, S)) where
+
+data Nat = Z | S Nat

src/Data/Type/Nat.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
-module Data.Type.Nat (Nat, Zero, Succ, TOrdering, GT, EQ, LT, Compare, GTorEQ) where
-
-class Nat n
-data Zero
-instance Nat Zero
-data Succ n
-instance (Nat n) => Nat (Succ n)
-
-class TOrdering c
-data GT
-instance TOrdering GT
-data EQ
-instance TOrdering EQ
-data LT
-
-class Compare n m c | n m -> c
-
-instance Compare Zero Zero EQ
-instance Nat n => Compare (Succ n) Zero GT
-instance Nat n => Compare Zero (Succ n) LT
-instance (Nat n, Nat m, TOrdering c, Compare n m c) => Compare (Succ n) (Succ m) c
-
-class GTorEQ n m
-instance GTorEQ Zero Zero
-instance Nat n => GTorEQ n n
-instance Nat n => GTorEQ (Succ n) Zero
-instance (Nat n, Nat m, GTorEQ n m) => GTorEQ (Succ n) (Succ m)

src/Data/Vec.hs

@@ -1,28 +1,20 @@
-{-# LANGUAGE GADTs, TypeOperators, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE GADTs, TypeOperators, DataKinds #-}
-module Data.Vec (Vec (Empty, (:.)), (!.), elemIndexVec) where
+module Data.Vec (Vec (Empty, (:.)), (!.), elemIndex) where
 
-import Data.Fin (Fin (Zero, Succ))
+import Data.Fin (Fin (FZ, FS))
-import Data.Type.Nat (Nat, Zero, Succ)
+import Data.Nat (Nat (Z, S))
 
 data Vec n a where
-  Empty :: Vec Zero a
+  Empty :: Vec 'Z a
-  (:.)  :: Nat n => a -> Vec n a -> Vec (Succ n) a
+  (:.)  :: a -> Vec n a -> Vec ('S n) a
 
-instance Nat n => Functor (Vec n) where
+(!.) :: Vec n a -> Fin n -> a
-  fmap _ Empty     = Empty
+(x :. _ ) !. FZ     = x
-  fmap f (x :. xs) = f x :. fmap f xs
+(_ :. xs) !. (FS n) = xs !. n
+_         !. _      = error "Impossible"
 
-instance Nat n => Foldable (Vec n) where
+elemIndex :: Eq a => a -> Vec n a -> Maybe (Fin n)
-  foldr _ base Empty     = base
+elemIndex _ Empty = Nothing
-  foldr f base (x :. xs) = x `f` foldr f base xs
+elemIndex x (x' :. xs)
-
+  | x == x'   = Just FZ
-(!.) :: Nat n => Vec n a -> Fin n -> a
+  | otherwise = FS <$> elemIndex x xs
-(x :. _ ) !. Zero     = x
-(_ :. xs) !. (Succ n) = xs !. n
-_         !. _        = error "Impossible"
-
-elemIndexVec :: (Eq a, Nat n) => a -> Vec n a -> Maybe (Fin n)
-elemIndexVec _ Empty = Nothing
-elemIndexVec x (x' :. xs)
-  | x == x'   = Just Zero
-  | otherwise = Succ <$> elemIndexVec x xs

src/UntypedLambdaCalculus.hs

@@ -1,73 +1,72 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs, FlexibleInstances, DataKinds #-}
 module UntypedLambdaCalculus (Expr (Free, Var, Lam, App), eval) where
 
 import Control.Monad.Reader (Reader, runReader, withReader, reader, asks)
-import Data.Fin (Fin (Zero, Succ), finRemove)
+import Data.Fin (Fin (FZ, FS), extract, coerceFin)
-import Data.Injection (Injection, inject)
+import Data.Functor ((<&>))
-import Data.Type.Nat (Nat, Succ, Zero)
+import Data.Nat (Nat (S, Z))
 import Data.Vec (Vec (Empty, (:.)), (!.))
 
 -- | A lambda calculus expression where variables are identified
 -- | by their distance from their binding site (De Bruijn indices).
 data Expr n = Free String
             | Var (Fin n)
-            | Lam String (Expr (Succ n))
+            | Lam String (Expr ('S n))
             | App (Expr n) (Expr n)
 
-instance (Nat n) => Injection (Expr n) (Expr (Succ n)) where
+coerceExpr :: Expr n -> Expr ('S n)
-  inject (Free v)  = Free v
+coerceExpr (Free v)  = Free v
-  inject (Var v)   = Var $ inject v
+coerceExpr (Var v)   = Var $ coerceFin v
-  inject (Lam v e) = Lam v $ inject e
+coerceExpr (Lam v e) = Lam v $ coerceExpr e
-  inject (App f x) = App (inject f) (inject x)
+coerceExpr (App f x) = App (coerceExpr f) (coerceExpr x)
 
-instance Show (Expr Zero) where
+instance Show (Expr 'Z) where
-  show expr = runReader (alg expr) Empty
+  show expr = runReader (show' expr) Empty
-    where alg :: Nat n => Expr n -> Reader (Vec n String) String
+    where show' :: Expr n -> Reader (Vec n String) String
-          alg (Free v)   = return v
+          show' (Free v)    = return v
-          alg (Var  v)   = reader (\vars -> vars !. v ++ ':' : show v)
+          show' (Var  v)    = reader (\vars -> vars !. v ++ ':' : show v)
-          alg (Lam  v e) = do
+          show' (Lam  v e') = withReader (v :.) (show' e') <&>
-            body <- withReader (v :.) $ alg e
+                           \body -> "(\\" ++ v ++ ". " ++ body ++ ")"
-            return $ "(\\" ++ v ++ ". " ++ body ++ ")"
+          show' (App f' x') = do
-          alg (App f' x') = do
+                             f <- show' f'
-            f <- alg f'
+                             x <- show' x'
-            x <- alg x'
+                             return $ "(" ++ f ++ " " ++ x ++ ")"
-            return $ "(" ++ f ++ " " ++ x ++ ")"
 
 -- | Determine whether the variable bound by a lambda expression is used in its body.
 -- | This is used in eta reduction, where `(\x. f x)` reduces to `f` when `x` is not bound in `f`.
-unbound :: Nat n => Expr (Succ n) -> Bool
+unbound :: Expr ('S n) -> Bool
-unbound expr = runReader (alg expr) Zero
+unbound expr = runReader (unbound' expr) FZ
-  where alg :: Nat n => Expr (Succ n) -> Reader (Fin (Succ n)) Bool
+  where unbound' :: Expr ('S n) -> Reader (Fin ('S n)) Bool
-        alg (Free _)  = return True
+        unbound' (Free _)  = return True
-        alg (Var v)   = reader (/= v)
+        unbound' (Var v)   = reader (/= v)
-        alg (App f x) = (&&) <$> alg f <*> alg x
+        unbound' (App f x) = (&&) <$> unbound' f <*> unbound' x
-        alg (Lam _ e) = withReader Succ $ alg e
+        unbound' (Lam _ e) = withReader FS $ unbound' e
 
 -- | When we bind a new variable, we enter a new scope.
 -- | Since variables are identified by their distance from their binder,
 -- | we must increment them to account for the incremented distance,
 -- | thus embedding them into the new expression.
-embed' :: Nat n => Expr n -> Expr (Succ n)
+embed :: Expr n -> Expr ('S n)
-embed' (Var v) = Var $ Succ v
+embed   (Var v) = Var $ FS v
-embed' o@(Lam _ _) = inject o
+embed o@(Lam _ _) = coerceExpr o
-embed' (Free x) = Free x
+embed   (Free x) = Free x
-embed' (App f x) = App (embed' f) (embed' x)
+embed   (App f x) = App (embed f) (embed x)
 
-subst :: Nat n => Expr n -> Expr (Succ n) -> Expr n
+subst :: Expr n -> Expr ('S n) -> Expr n
-subst value expr = runReader (subst' value expr) Zero
+subst value expr = runReader (subst' value expr) FZ
-  where subst' :: Nat n => Expr n -> Expr (Succ n) -> Reader (Fin (Succ n)) (Expr n)
+  where subst' :: Expr n -> Expr ('S n) -> Reader (Fin ('S n)) (Expr n)
         subst' _   (Free x)  = return $ Free x
-        subst' val (Var x)   = maybe val Var <$> asks (finRemove x)
+        subst' val (Var x)   = maybe val Var <$> asks (extract x)
         subst' val (App f x) = App <$> subst' val f <*> subst' val x
-        subst' val (Lam v e) = Lam v <$> withReader Succ (subst' (embed' val) e)
+        subst' val (Lam v e) = Lam v <$> withReader FS (subst' (embed val) e)
 
 -- | Evaluate an expression to normal form.
-eval :: Nat n => Expr n -> Expr n
+eval :: Expr n -> Expr n
 eval (App f' x) = case eval f' of
   -- Beta reduction.
   Lam _ e -> eval $ subst x e
   f -> App f (eval x)
-eval o@(Lam _ (App f (Var Zero)))
+eval o@(Lam _ (App f (Var FZ)))
   -- Eta reduction. We know that `0` is not bound in `f`,
   -- so we can simply substitute it for undefined.
   | unbound f = eval $ subst undefined f

src/UntypedLambdaCalculus/Parser.hs

@@ -1,15 +1,12 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE DataKinds #-}
-module UntypedLambdaCalculus.Parser (expr) where
+module UntypedLambdaCalculus.Parser (parseExpr) where
 
-import Control.Applicative (liftA)
 import Control.Monad.Reader (ReaderT, runReaderT, withReaderT, mapReaderT, ask)
 import Control.Monad.Trans.Class (lift)
-import Data.Functor (void)
 import Data.List (foldl1')
-import Data.Type.Nat (Nat, Zero )
+import Data.Nat (Nat (Z))
-import Data.Vec (Vec (Empty, (:.)), elemIndexVec)
+import Data.Vec (Vec (Empty, (:.)), elemIndex)
-import Text.Parsec hiding (Empty)
+import Text.Parsec (Parsec, SourceName, ParseError, many, sepBy1, letter, alphaNum, char, between, (<|>), spaces, parse)
-import Unsafe.Coerce (unsafeCoerce)
 import UntypedLambdaCalculus (Expr (Free, Var, Lam, App))
 
 type Parser s a = ReaderT s (Parsec String ()) a
@@ -22,36 +19,26 @@ name = do
   return $ c : cs
 
 -- | A variable expression.
-var :: Nat n => Parser (Vec n String) (Expr n)
+var :: Parser (Vec n String) (Expr n)
 var = do
   varn <- lift name
   bound <- ask
-  return $ maybe (Free varn) Var $ elemIndexVec varn bound
+  return $ maybe (Free varn) Var $ elemIndex varn bound
 
 -- | Run parser between parentheses.
 parens :: Parsec String () a -> Parsec String () a
-parens p = do
+parens = between (char '(') (char ')')
-  _ <- char '('
-  x <- p
-  _ <- char ')'
-  return x
 
 -- | A lambda expression.
-lam :: Nat n => Parser (Vec n String) (Expr n)
+lam :: Parser (Vec n String) (Expr n)
 lam = do
-  vars <- lift $ do
+  (lift $ between (char '\\') (char '.' >> spaces) $ name `sepBy1` spaces) >>= help
-    _ <- char '\\'
+  where help :: [String] -> Parser (Vec n String) (Expr n)
-    vars <- name `sepBy1` spaces
-    _ <- char '.'
-    spaces
-    return vars
-  help vars
-  where help :: Nat n => [String] -> Parser (Vec n String) (Expr n)
         help []     = app
         help (v:vs) = Lam v <$> withReaderT (v :.) (help vs)
 
 -- | An application expression.
-app :: Nat n => Parser (Vec n String) (Expr n)
+app :: Parser (Vec n String) (Expr n)
 app = foldl1' App <$> mapReaderT (`sepBy1` spaces) safeExpr
 
 ll :: (Parsec String () a -> Parsec String () b -> Parsec String () c) -> Parser s a -> Parser s b -> Parser s c
@@ -62,10 +49,10 @@ ll f p1 p2 = do
 -- | An expression, but where applications must be surrounded by parentheses,
 -- | to avoid ambiguity (infinite recursion on `app` in the case where the first
 -- | expression in the application is also an `app`, consuming no input).
-safeExpr :: Nat n => Parser (Vec n String) (Expr n)
+safeExpr :: Parser (Vec n String) (Expr n)
 safeExpr = ll (<|>) var $ ll (<|>) lam $ mapReaderT parens (ll (<|>) lam app)
 
 -- | Since applications do not require parentheses and can contain only a single item,
 -- | the `app` parser is sufficient to parse any expression at all.
-expr :: SourceName -> String -> Either ParseError (Expr Zero)
+parseExpr :: SourceName -> String -> Either ParseError (Expr 'Z)
-expr sourceName code = parse (runReaderT app Empty) sourceName code
+parseExpr sourceName code = parse (runReaderT app Empty) sourceName code