Skip to content

Instantly share code, notes, and snippets.

@cstrahan
Forked from xgrommx/HRecursionSchemes.hs
Created November 26, 2018 05:30
Show Gist options
  • Save cstrahan/2e4c810f1bdfe65ae3be4b4a8b0eafe5 to your computer and use it in GitHub Desktop.
Save cstrahan/2e4c810f1bdfe65ae3be4b4a8b0eafe5 to your computer and use it in GitHub Desktop.
HRecursionSchemes
{-# LANGUAGE StandaloneDeriving, DataKinds, PolyKinds, GADTs, RankNTypes, TypeOperators, FlexibleContexts, TypeFamilies, KindSignatures #-}
-- http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html
module HRecursionSchemes where
import Control.Applicative
import Data.Functor.Identity
import Data.Functor.Const
import Text.PrettyPrint.Leijen hiding ((<>))
import Control.Monad.Free
import Control.Monad.Codensity
import Control.Monad.Trans.Class
import qualified Data.Vector as V
import Control.Monad ((<=<))
import Data.Monoid
import qualified Data.List as L
import Control.Monad.Trans.Writer
type f ~> g = forall a. f a -> g a
type family HBase (h :: ★ -> ★) :: (★ -> ★) -> (★ -> ★)
type NatM m f g = forall a. f a -> m (g a)
type HAlgebra h f = h f ~> f
type HAlgebraM m h f = NatM m (h f) f
type HCoalgebra h f = f ~> h f
type HCoalgebraM m h f = NatM m f (h f)
class HFunctor (h :: (★ -> ★) -> (★ -> ★)) where
hfmap :: (f ~> g) -> (h f ~> h g)
class HFunctor h => HFoldable (h :: (★ -> ★) -> (★ -> ★)) where
hfoldMap :: Monoid m => (forall b. f b -> m) -> h f a -> m
class HFoldable h => HTraversable (h :: (★ -> ★) -> (★ -> ★)) where
htraverse :: Applicative e => NatM e f g -> NatM e (h f) (h g)
class HFunctor (HBase h) => HRecursive (h :: ★ -> ★) where
hproject :: h ~> (HBase h) h
hcata :: HAlgebra (HBase h) f -> h ~> f
hcata algebra = algebra . hfmap (hcata algebra) . hproject
class HFunctor (HBase h) => HCorecursive (h :: ★ -> ★) where
hembed :: (HBase h) h ~> h
hana :: (f ~> (HBase h) f) -> f ~> h
hana coalgebra = hembed . hfmap (hana coalgebra) . coalgebra
hhylo :: HFunctor f => HAlgebra f b -> HCoalgebra f a -> a ~> b
hhylo f g = f . hfmap (hhylo f g) . g
hcataM :: (Monad m, HTraversable (HBase h), HRecursive h) => HAlgebraM m (HBase h) f -> h a -> m (f a)
hcataM f = f <=< htraverse (hcataM f) . hproject
hanaM :: (Monad m, HTraversable (HBase h), HCorecursive h) => HCoalgebraM m (HBase h) f -> f a -> m (h a)
hanaM f = fmap hembed . htraverse (hanaM f) <=< f
hhyloM :: (HTraversable t, Monad m) => HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)
hhyloM f g = f <=< htraverse(hhyloM f g) <=< g
data Expr :: ★ -> ★ where
ELitInt :: Int -> Expr Int
ELitBool :: Bool -> Expr Bool
EAdd :: Expr Int -> Expr Int -> Expr Int
ELessThan :: Expr Int -> Expr Int -> Expr Bool
EIf :: Expr Bool -> Expr a -> Expr a -> Expr a
-- data ExprF (h :: ★ -> ★) (t :: ★) where
data ExprF :: (★ -> ★) -> ★ -> ★ where
ELitIntF :: Int -> ExprF h Int
ELitBoolF :: Bool -> ExprF h Bool
EAddF :: h Int -> h Int -> ExprF h Int
ELessThanF :: h Int -> h Int -> ExprF h Bool
EIfF :: h Bool -> h a -> h a -> ExprF h a
instance HFunctor ExprF where
hfmap f x = case x of
ELitIntF n -> ELitIntF n
ELitBoolF b -> ELitBoolF b
EAddF x y -> EAddF (f x) (f y)
ELessThanF x y -> ELessThanF (f x) (f y)
EIfF c t f' -> EIfF (f c) (f t) (f f')
instance HFoldable ExprF where
hfoldMap f x = case x of
ELitIntF n -> mempty
ELitBoolF b -> mempty
EAddF x y -> (f x) <> (f y)
ELessThanF x y -> (f x) <> (f y)
EIfF c t f' -> (f c) <> (f t) <> (f f')
instance HTraversable ExprF where
htraverse f x = case x of
ELitIntF n -> pure (ELitIntF n)
ELitBoolF b -> pure (ELitBoolF b)
EAddF x y -> liftA2 EAddF (f x) (f y)
ELessThanF x y -> liftA2 ELessThanF (f x) (f y)
EIfF c t f' -> liftA3 EIfF (f c) (f t) (f f')
type instance HBase Expr = ExprF
instance HRecursive Expr where
hproject x = case x of
ELitInt n -> ELitIntF n
ELitBool b -> ELitBoolF b
EAdd x y -> EAddF x y
ELessThan x y -> ELessThanF x y
EIf c t f -> EIfF c t f
instance HCorecursive Expr where
hembed x = case x of
ELitIntF n -> ELitInt n
ELitBoolF b -> ELitBool b
EAddF x y -> EAdd x y
ELessThanF x y -> ELessThan x y
EIfF c t f -> EIf c t f
data Value ix where
VInt :: Int -> Value Int
VBool :: Bool -> Value Bool
deriving instance Show (Value ix)
halgI :: ExprF Identity ~> Identity
halgI x = case x of
ELitIntF n -> Identity n
ELitBoolF b -> Identity b
EAddF (Identity x) (Identity y) -> Identity (x + y)
ELessThanF (Identity x) (Identity y) -> Identity (x < y)
EIfF (Identity c) t f -> if c then t else f
halgC :: ExprF (Const Doc) ~> Const Doc
halgC x = case x of
ELitIntF n -> Const . text $ show n
ELitBoolF b -> Const . text $ show b
EAddF (Const a) (Const b) -> Const . parens $ a <+> text "+" <+> b
ELessThanF (Const a) (Const b) -> Const . parens $ a <+> text "<" <+> b
EIfF (Const a) (Const b) (Const c) -> Const $ text "if" <+> a <+> text "then" <+> b <+> text "else" <+> c
halg :: ExprF Value ~> Value
halg x = case x of
ELitIntF n -> VInt n
ELitBoolF b -> VBool b
EAddF (VInt x) (VInt y) -> VInt (x + y)
ELessThanF (VInt x) (VInt y) -> VBool (x < y)
EIfF (VBool c) t f -> if c then t else f
-- heval :: (HBase h ~ ExprF, HRecursive h) => h a -> Value a
heval :: Expr ~> Value
heval = hcata halg
value = EIf (ELitBool False) (ELitInt 1) (EAdd (ELitInt 42) (ELitInt 45))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment