Main.hs

{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, KindSignatures, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}

module Main where

import Data.Monoid hiding (Sum(..))
import Data.Sum

-- okay, let's use Data.Sum to solve the expression problem
-- we'll build a little expression language, define an F-algebra, and print it out
-- you don't _have_ to use recursion schemes with Data.Sum, but they sure are nice

-- standard fixed point of a Functor. in the real world we would use an actual
-- recursion schemes library, but who has time for that?
newtype Fix f = In { out :: f (Fix f) }

-- here's our expression type - note that l is a type-level list of functors
type Expr (l :: [* -> *]) = Fix (Sum l)

-- numbers
newtype Lit a = Lit Int deriving Functor

-- smart constructor. the :< is pronounced "member":
-- what this says is that as long as Lit is a member of the type-level
-- list 'fs', we can inj it into an Expr that contains 'fs'
-- if we tried to inj it into an 'Expr [Thing1, Thing2]',
-- we would get an error message that Lit cannot be found in [Thing1, Thing2]
lit :: (Lit :< fs) => Int -> Expr fs
lit = In . inject . Lit

-- parens
newtype Paren a = Paren a
  deriving Functor

paren :: (Paren :< fs) => Expr fs -> Expr fs
paren = In . inject . Paren

-- math
data Op a
  = Add a a
  | Sub a a
  | Mul a a
    deriving Functor

(+:), (-:), (*:) :: (Op :< fs) => Expr fs -> Expr fs -> Expr fs
a +: b = In (inject (Add a b))
a -: b = In (inject (Sub a b))
a *: b = In (inject (Mul a b))

infixl 6 +:
infixl 6 -:
infixl 7 *:

-- here's our F-algebra that converts a sum type to a string
class Functor f => Pretty f where
  pretty :: f String -> String

instance Pretty Lit where
  pretty (Lit i) = show i

instance Pretty Paren where
  pretty (Paren a) = "(" <> a <> ")"

instance Pretty Op where
  pretty (Add a b) = concat [a, " + ", b]
  pretty (Sub a b) = concat [a, " - ", b]
  pretty (Mul a b) = concat [a, " * ", b]

-- this tells the compiler that any Sum type whose components
-- all implement Functor and Pretty supports pretty-printing too
instance (Apply Functor fs, Apply Pretty fs) => Pretty (Sum fs) where
  pretty = apply @Pretty pretty

-- a neutered catamorphism
runPretty :: Pretty f => Fix f -> String
runPretty = pretty . fmap runPretty . out

example :: Expr '[Lit, Op, Paren]
example = paren (lit 5 +: lit 10) *: lit 2

main :: IO ()
main = putStrLn (runPretty example)

-- now, if you so desired, you could add a new data type:
-- > data Div a = Div a a
-- declare a Pretty instance for it, and then create a new value of type
-- > Expr '[Lit, Op, Paren, Div]
-- and you get a perfect solution to the expression problem: seamless extension of functionality and of data-types