{-# 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