Recursion schemes in one page, no dependencies

Recursion.hs

{-# language DeriveDataTypeable #-}
{-# language FlexibleContexts #-}
{-# language StandaloneDeriving #-}
{-# language TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# language TypeFamilies #-}
module Data.Recursion where

import Data.Data (Data)
import           Data.Functor.Classes (Read1(..), Show1(..), Eq1(..), Ord1(..), Show1(..), compare1, eq1, showsPrec1, readsPrec1)
import Data.Typeable (Typeable)

import Data.Kind (Type)
import           Text.Read (Read(..), Lexeme(..), parens, prec, lexP, step, readS_to_Prec)


{- |
Module      :  Data.Recursion
Description :  recursion schemes, no dependencies
Copyright   :  (c) 2008-2015 Edward Kmett, 2011-2016 Balazs Komuves
License     :  BSD-style
Stability   :  stable

recursion schemes machinery, relying only on 'base' as a dependency

definitions taken from 'micro-recursion-schemes' and 'fixplate'
-}


type family Base t :: Type -> Type

class Functor (Base t) => Recursive t where
  project :: t -> Base t t

  cata :: (Base t a -> a) -- ^ a (Base t)-algebra
       -> t               -- ^ fixed point
       -> a               -- ^ result
  cata f = c where c = f . fmap c . project

class Functor (Base t) => Corecursive t where
  embed :: Base t t -> t
  ana
    :: (a -> Base t a) -- ^ a (Base t)-coalgebra
    -> a               -- ^ seed
    -> t               -- ^ resulting fixed point
  ana g = a where a = embed . fmap a . g


-------------------------------------------------------------------------------
-- Fix
-------------------------------------------------------------------------------

newtype Fix f = Fix (f (Fix f))

unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f

instance Eq1 f => Eq (Fix f) where
  Fix a == Fix b = eq1 a b

instance Ord1 f => Ord (Fix f) where
  compare (Fix a) (Fix b) = compare1 a b

instance Show1 f => Show (Fix f) where
  showsPrec d (Fix a) =
    showParen (d >= 11)
      $ showString "Fix "
      . showsPrec1 11 a

instance Read1 f => Read (Fix f) where
  readPrec = parens $ prec 10 $ do
    Ident "Fix" <- lexP
    Fix <$> step (readS_to_Prec readsPrec1)

deriving instance Typeable Fix
deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)

type instance Base (Fix f) = f
instance Functor f => Recursive (Fix f) where
  project (Fix a) = a
instance Functor f => Corecursive (Fix f) where
  embed = Fix

refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix = cata embed

toFix :: Recursive t => t -> Fix (Base t)
toFix = refix

fromFix :: Corecursive t => Fix (Base t) -> t
fromFix = refix

-- | ---------------------------------------------------------------------------
-- | decorating trees
--
-- from https://hackage.haskell.org/package/fixplate-0.1.7/docs/Data-Generics-Fixplate-Attributes.html
--
-- | ---------------------------------------------------------------------------

-- | Type of annotations
data Ann f a b = Ann
  { attr  :: a           -- ^ the annotation
  , unAnn :: f b         -- ^ the original functor
  }
  deriving (Eq,Ord,Show)

-- | Annotated fixed-point type. Equivalent to @CoFree f a@
type Attr f a = Fix (Ann f a)

-- | The attribute of the root node.
attribute :: Attr f a -> a
attribute = attr . unfix

-- | A function forgetting all the attributes from an annotated tree.
-- forget :: Functor f => Attr f a -> Mu f
forget :: Functor f => Attr f a -> Fix f
forget = Fix . fmap forget . unAnn . unfix

-- | Decorate a tree bottom-up (all subtrees first)
synthCata :: Functor f => (f a -> a) -> Fix f -> Attr f a
synthCata h = go where
  go (Fix x) = Fix $ Ann (h a) y
    where
      y  =  fmap go x
      a  =  fmap attribute y

-- | monadic version of synthCata
synthCataM :: (Monad m, Traversable f) =>
              (f a -> m a) -> Fix f -> m (Attr f a)
synthCataM act = go where
  go (Fix x) = do
    y  <-  mapM go x
    a  <-  act $ fmap attribute y
    return (Fix (Ann a y))

scanCata :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
scanCata h =  go where
  go (Fix (Ann a x)) = Fix $ Ann (h a b) y where
    y  =  fmap go x
    b  =  fmap attribute y

-- | Decorate a tree top-down (from the root)
inherit :: Functor f =>
           (Fix f -> a -> a) -> a -> Fix f -> Attr f a
inherit h root = go root where
  go p s@(Fix t) = let a = h s p in Fix (Ann a (fmap (go a) t))

inheritM :: (Monad m, Traversable f) =>
            (Fix f -> a -> m a) -> a -> Fix f -> m (Attr f a)
inheritM act root = go root where
  go p s@(Fix t) = do
    a <- act s p
    u <- mapM (go a) t
    return (Fix (Ann a u))