Skip to content

Instantly share code, notes, and snippets.

@cstrahan

cstrahan/HRecursionSchemes.hs

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.
Download ZIP

Revisions

  1. @xgrommx xgrommx revised this gist Jul 17, 2018. 1 changed file with 64 additions and 18 deletions.
    82 changes: 64 additions & 18 deletions HRecursionSchemes.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -4,57 +4,102 @@

    module HRecursionSchemes where

    import Control.Applicative
    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 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
    class HFunctor (h :: (★ -> ★) -> (★ -> ★)) where
    hfmap :: (f ~> g) -> (h f ~> h g)

    class HFunctor (HBase h) => HRecursive (h :: * -> *) where
    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
    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

    data Expr :: * -> * where
    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 :: (* -> *) -> * -> * where
    -- 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')
    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

    @@ -63,24 +108,24 @@ instance HRecursive Expr where
    ELitInt n -> ELitIntF n
    ELitBool b -> ELitBoolF b
    EAdd x y -> EAddF x y
    ELessThan x y -> ELessThanF 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
    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)
    deriving instance Show (Value ix)

    halgI :: ExprF Identity t -> Identity t
    halgI :: ExprF Identity ~> Identity
    halgI x = case x of
    ELitIntF n -> Identity n
    ELitBoolF b -> Identity b
    @@ -96,15 +141,16 @@ halgC x = case x of
    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 t -> Value t
    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 :: Expr a -> Value a
    -- 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))
  2. @xgrommx xgrommx created this gist Nov 29, 2017.
    110 changes: 110 additions & 0 deletions HRecursionSchemes.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,110 @@
    {-# 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 ((<>))

    type f ~> g = forall a. f a -> g a

    type family HBase (h :: * -> *) :: (* -> *) -> (* -> *)

    type HAlgebra h f = h f ~> f
    type HCoalgebra h f = f ~> h f

    class HFunctor (h :: (* -> *) -> (* -> *)) where
    hfmap :: (f ~> g) -> (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

    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 :: (* -> *) -> * -> * 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')

    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 t -> Identity t
    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 t -> Value t
    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 :: Expr a -> Value a
    heval = hcata halg

    value = EIf (ELitBool False) (ELitInt 1) (EAdd (ELitInt 42) (ELitInt 45))