Skip to content

Instantly share code, notes, and snippets.

@llelf
Forked from dredozubov/alacarte.hs
Last active September 5, 2019 08:51
Show Gist options
  • Save llelf/2df24b1cb8a9de5576011fe685d9c76e to your computer and use it in GitHub Desktop.
Save llelf/2df24b1cb8a9de5576011fe685d9c76e to your computer and use it in GitHub Desktop.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module ALaCarte where
(∘) = (.)
data Expr f = In (f (Expr f))
data (f + g) e = Inl (f e) | Inr (g e)
deriving (Functor, Show, Eq)
class sub ≺ sup where
inj :: sub a -> sup a
instance (Functor sub) => sub ≺ sub where
inj = id
instance {-# OVERLAPPING #-} (Functor f, Functor g) => f ≺ (f + g) where
inj = Inl
instance {-# OVERLAPPABLE #-}
(Functor f, Functor g, Functor h, f ≺ g) => f ≺ (h + g) where
inj = Inr ∘ inj
foldExpr :: Functor f => (f a -> a) -> Expr f -> a
foldExpr f (In e) = f (foldExpr f <$> e)
eval :: forall f. (Functor f, Eval f) => Expr f -> Int
eval = foldExpr evalAlgebra
class Eval f where
evalAlgebra :: f Int -> Int
instance (Eval f, Eval g) => Eval (f + g) where
evalAlgebra (Inl x) = evalAlgebra x
evalAlgebra (Inr y) = evalAlgebra y
-- constructors
data Val e = Val Int deriving (Functor, Show, Eq)
instance Eval Val where
evalAlgebra (Val i) = i
data Add e = Add e e deriving (Functor, Show, Eq)
instance Eval Add where
evalAlgebra (Add x y) = x + y
-- smart constructors
inject :: (g ≺ f) => g (Expr f) -> Expr f
inject = In ∘ inj
val :: (Val ≺ f) => Int -> Expr f
val = inject ∘ Val
(⊕) :: (Add ≺ f) => Expr f -> Expr f -> Expr f
x ⊕ y = inject (Add x y)
infixl 7 ⊕
main = do
let x ::Expr (Add + Val) = val 30000 ⊕ val 1330 ⊕ val 7
print $ eval x
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment