Схемы рекурсии с использованием `Fix` для типа данных, который уже является функтором?

После долгой борьбы я пришел к выводу, что лучше всего определить два типа данных; стандартный тип данных, который имеет нужные вам свойства (в данном случае Bifunctor) и тип данных Recursive Functor, для которого вы можете определить экземпляры Base, Recursive и Corecursive.

Вот как это выглядит:

{-# language DeriveFunctor, DeriveTraversable, TypeFamilies  #-}

import Data.Typeable
import Data.Bifunctor
import Data.Functor.Foldable

data BiTree b l =
  Branch b (BiTree b l) (BiTree b l)
    | Leaf l
    deriving (Show, Typeable, Functor, Traversable, Foldable)

instance Bifunctor BiTree where
  bimap _ g (Leaf x) = Leaf (g x)
  bimap f g (Branch b l r) = Branch (f b) (bimap f g l) (bimap f g r)

data BiTreeF b l r =
  BranchF b r r
    | LeafF l
    deriving (Show, Functor, Typeable)

type instance Base (BiTree a b) = BiTreeF a b
instance Recursive (BiTree a b) where
  project (Leaf x) = LeafF x
  project (Branch s l r) = BranchF s l r

instance Corecursive (BiTree a b) where
  embed (BranchF sp x xs) = Branch sp x xs
  embed (LeafF x) = Leaf x

Теперь вы можете использовать свой базовый тип (BiTree) во всем коде, как обычно; и когда вы решите использовать схему рекурсии, вам просто нужно помнить, что при распаковке вы используете F-версии конструкторов:

anyActiveWindows :: Window -> Bool
anyActiveWindows = cata alg
  where alg (LeafF vw) = vw^.active
        alg (BranchF _ l r) = l || r

Обратите внимание, что если вы в конечном итоге перестроите набор окон, вы все равно будете использовать версии NON-F в правой части =.

Для своего сценария я определил следующее, и он отлично работает; У меня есть Functor и Bifunctor для Window, как я и хотел, даже не используя newtype:

type Window = BiTree Split View

data SplitRule =
  Percentage Double
  | FromStart Int
  | FromEnd Int
  deriving (Show)

data Dir = Hor
        | Vert
        deriving (Show)

data Split = Split
  { _dir :: Dir
  , _splitRule :: SplitRule
  } deriving (Show)

makeLenses ''Split

data View = View
  { _active :: Bool
  , _bufIndex :: Int
  } deriving (Show)

makeLenses ''View

Да, вы хотите использовать версию Fix от Data.Bifunctor.Fix:

newtype Fix p a = In { out :: p (Fix p a) a }

instance Bifunctor p => Functor (Fix p) where
  fmap f (In x) = In (bimap (fmap f) f x)

Вам нужно будет изменить свой WindowF тип, чтобы он соответствовал:

data WindowF r a =
  Split Dir SplitInfo r r
    | Single ViewInfo a
    deriving (Show, Functor)

instance Bifunctor WindowF where
  bimap f _g (Split dir si x y) = Split dir si (f x) (f y)
  bimap _f g (Single vi a) = Single vi (g a)

newtype Window a = Window (Fix WindowF a) deriving Functor

С этим можно использовать recursion-schemes вместе со вспомогательным типом:

import Data.Functor.Foldable hiding (Fix (..))
import Data.Profunctor.Unsafe
import Data.Coerce

newtype Flip p a b = Flip {unFlip :: p b a}

instance Bifunctor p => Bifunctor (Flip p) where
  bimap f g (Flip x) = Flip (bimap g f x)

instance Bifunctor p => Functor (Flip p a) where
  fmap = coerce (first :: (x -> y) -> p x a -> p y a)
    :: forall x y . (x -> y) -> Flip p a x -> Flip p a y

type instance Base (Fix p a) = Flip p a
instance Bifunctor p => Recursive (Fix p a) where
  project = Flip #. out
  cata f = f . Flip . first (cata f) . out

К сожалению, определение Recursive для версии с оболочкой newtype немного сложнее:

newtype Window a = Window {getWindow :: Fix WindowF a} deriving (Functor)
type instance Base (Window a) = Flip WindowF a

instance Recursive (Window a) where
  project = coerce #. project .# getWindow
  cata = (. getWindow) #. cata