HRecursionSchemes

HRecursionSchemes.hs

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