SybViaGeneric.hs

-- unleash the zoo
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ConstraintKinds #-}

module GenericSYB (g) where
import GHC.Generics as G
import GHC.Types

g :: [Maybe Int]
g = biplate f ls
  where
    f :: Int -> Int
    f i = i + 1
    ls ::  [Maybe Int]
    ls = [Just 3, Nothing, Just 4]

data Oracle b a where
  Hit :: Oracle a a 
  Recurse :: Oracle a b
  Miss :: Oracle a b


deriving instance (BiplateSuper b (Maybe a)) => Biplate b (Maybe a)
deriving instance (BiplateSuper b [a]) => Biplate b [a]
instance (BiplateSuper b Int) => Biplate b Int where
    type GetOracle _ b Int = Primitive b Int

-- DispatchOracle is total so I hoped we could get away with a
-- (Generic a, GenericBiplate b (Rep a)) constraint.
-- Don't see how to get proof without a constraint, though.
-- Maybe in dependent haskell DispatchOracle could be a normal function?
type BiplateSuper b a = DispatchOracle b a (GetOracle '[] b a)

class DispatchOracle b a (o :: Oracle b a) where 
    dispatchOracle :: proxy o -> (b -> b) -> a -> a
instance (Generic a, GenericBiplate b (Rep a)) => DispatchOracle b a 'Recurse where
    dispatchOracle _ f a = to $ genericBiplate f (from a)
instance DispatchOracle a a 'Hit where
    dispatchOracle _ f a =  f a
instance DispatchOracle b a 'Miss where
    dispatchOracle _ _ a =  a

class Biplate b a where
    type family GetOracle (seen:: [Type]) b a :: Oracle b a
    type instance GetOracle seen b a = GenericOracleWith seen b a
    biplate :: (b -> b) -> a -> a
    default biplate :: (BiplateSuper b a) => (b -> b) -> a -> a
    biplate f a = dispatchOracle (undefined :: proxy (GetOracle '[] b a)) f a

type family GenericOracleWith seen b a :: Oracle b a where
    GenericOracleWith _ a a = 'Hit
    -- this is a shitty set so we don't get stuck in recursive types
    GenericOracleWith seen b a =  (RepOracleWith (a ': seen) b (Rep a))
type family IsSeen seen a where
    IsSeen '[] _ = 'False
    IsSeen (x ': xs) x = 'True
    IsSeen (_ ': xs) x = IsSeen xs x
-- this made both me and ghc go loopy until figuring this out
-- Turns out type families are strict in their arguments so we can't abstract over the if branches
type family IfSeen c seen b a where
    IfSeen 'True _ _ _ = 'Miss
    IfSeen 'False seen b a  = (AfterRecurse (GetOracle seen b a))
type family RepOracleWith seen (b::Type) (a::Type -> Type) where
    RepOracleWith seen b (M1 _i _c a) = RepOracleWith seen b a
    RepOracleWith seen b (K1 _i a) = IfSeen (IsSeen seen a) seen b a 
    RepOracleWith seen b (U1) = 'Miss
    RepOracleWith seen b V1 = 'Miss
    RepOracleWith seen b ((:+:) a1 a2) = MeetOracle (RepOracleWith seen b a1) (RepOracleWith seen b a2)
    RepOracleWith seen b ((:*:) a1 a2) = MeetOracle (RepOracleWith seen b a1) (RepOracleWith seen b a2)

type family AfterRecurse b where
   AfterRecurse 'Miss = 'Miss
   AfterRecurse _ = 'Recurse

-- We only work with Miss and Recurse here. There probably is a theoretically nicer way to express this
type family MeetOracle b a where
    MeetOracle 'Miss 'Miss = 'Miss
    MeetOracle _ _ = 'Recurse

type family Primitive b a :: Oracle b a where
    Primitive a a = 'Hit
    Primitive b a = 'Miss

class GenericBiplate b repa  where
    genericBiplate :: (b -> b) -> repa x -> repa x
instance (GenericBiplate b a) => GenericBiplate b (M1 i c a) where
    genericBiplate f (M1 a) = M1 (genericBiplate f a)
instance (Biplate b a) => GenericBiplate b (K1 i a) where
    genericBiplate f (K1 a) = K1 (biplate f a)
instance (GenericBiplate b l, GenericBiplate b r) => GenericBiplate b ((:*:) l r) where
    genericBiplate f (l :*: r) = genericBiplate f l :*: genericBiplate f r
instance (GenericBiplate b l, GenericBiplate b r) => GenericBiplate b ((:+:) l r) where
    genericBiplate f (L1 a) = L1 (genericBiplate f a)
    genericBiplate f (R1 a) = R1 (genericBiplate f a)
instance GenericBiplate _b U1 where
    genericBiplate _ U1 = U1
instance GenericBiplate _b V1 where
    genericBiplate _ a = a