An experiment with modeling a nanopass compiler with coproducts and recursion-schemes, inspired by https://git.io/v9ha1

LambdaCoproduct.hs

#!/usr/bin/env stack
-- stack script --resolver=lts-8.14 --package recursion-schemes --package transformers --package deriving-compat
{-# LANGUAGE TypeOperators
           , DeriveFunctor
           , DeriveFoldable
           , DeriveTraversable
           , DeriveGeneric
           , TemplateHaskell
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
           #-}

module Main where

import Data.String

import Data.Functor.Sum
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Deriving

import Debug.Trace

import GHC.Generics (Generic)

infixr 6 :+:
type (:+:) = Sum

class (Functor sub, Functor sup) => sub :<: sup where
  inj :: sub a -> sup a
  prj :: sup a -> Maybe (sub a)

inject' :: f :<: g => f (Fix g) -> Fix g
inject' = Fix . inj

project' :: f :<: g => Fix g -> Maybe (f (Fix g))
project' (Fix f) = prj f

instance Functor f => f :<: f where
  inj = id
  prj = Just

instance {-# OVERLAPPING #-} (Functor f, Functor g) => f :<: (f :+: g) where
  inj = InL

  prj (InL fa) = Just fa
  prj _        = Nothing

instance (Functor f, Functor g, Functor h, f :<: h) => f :<: (g :+: h) where
  inj = InR . inj

  prj (InR ha) = prj ha
  prj _        = Nothing

type Name = String

data CoreF a
  = Var Name
  | Abs Name a
  | App a a
  deriving (Functor, Foldable, Traversable, Generic)

$(deriveEq1   ''CoreF)
$(deriveOrd1  ''CoreF)
$(deriveShow1 ''CoreF)
$(deriveRead1 ''CoreF)

mkVar :: CoreF :<: f => Name -> Fix f
mkVar = inject' . Var

mkAbs :: CoreF :<: f => Name -> Fix f -> Fix f
mkAbs n = inject' . Abs n

mkApp :: CoreF :<: f => Fix f -> Fix f -> Fix f
mkApp f x = inject' (App f x)

data LetF a
  = Let Name a a
  deriving (Functor, Foldable, Traversable, Generic)

$(deriveEq1   ''LetF)
$(deriveOrd1  ''LetF)
$(deriveShow1 ''LetF)
$(deriveRead1 ''LetF)

mkLet :: LetF :<: f => Name -> Fix f -> Fix f -> Fix f
mkLet n v b = inject' (Let n v b)

data NatF a
  = Zero
  | Succ a
  deriving (Functor, Foldable, Traversable, Generic)

$(deriveEq1   ''NatF)
$(deriveOrd1  ''NatF)
$(deriveShow1 ''NatF)
$(deriveRead1 ''NatF)

mkZero :: NatF :<: f => Fix f
mkZero = inject' Zero

mkSucc :: NatF :<: f => Fix f -> Fix f
mkSucc = inject' . Succ

type Expr = Fix (NatF :+: LetF :+: CoreF)

transCata :: (Functor f, Functor g) => (g (Fix f) -> f (Fix f)) -> Fix g -> Fix f
transCata f = cata (embed . f)

expandLet :: CoreF :<: f => (LetF :+: f) (Fix f) -> f (Fix f)
expandLet (InR expr)        = expr
expandLet (InL (Let x v b)) = inj (App (mkAbs x b) v)

desugarLet :: CoreF :<: f => Fix (LetF :+: f) -> Fix f
desugarLet = transCata expandLet

expandNat :: CoreF :<: f => (NatF :+: f) (Fix f) -> f (Fix f)
expandNat (InR expr)     = expr
expandNat (InL Zero)     = inj (Abs "f" (mkAbs "x" (mkVar "x")))
expandNat (InL (Succ n)) = inj (Abs "f" (mkAbs "x" (mkApp (mkVar "f") (mkApp n (mkApp (mkVar "f") (mkVar "x"))))))

desugarNat :: CoreF :<: f => Fix (NatF :+: f) -> Fix f
desugarNat = transCata expandNat

desugar :: CoreF :<: f => Fix (NatF :+: LetF :+: f) -> Fix f
desugar = desugarLet . desugarNat

expr :: Expr
expr = mkLet "id" (mkAbs "x" (mkVar "x")) (mkApp (mkVar "id") (mkSucc mkZero))

main :: IO ()
main = do
  print expr
  print (desugar expr)