{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}


module T21577 (bar) where

import GHC.Generics
import GHC.Exts (Constraint)
import Data.Coerce (coerce)
import Data.Kind (Type)

data A = A ()
  deriving Generic

data B = B A

-- This avoids callstack stuff in core dumps
undefined' :: a
undefined' = undefined'

ba :: Optic A_Setter B B A A
ba = castOptic $ lens (\(B a) -> a) (\_ -> B)

aunit :: Optic A_Setter A A () ()
aunit = case foo (Market id Right) of
  Market _ _ -> Optic undefined'
 where
   foo :: Profunctor p => p i () () -> p i A A
   foo = dimap from to . dimap coerce coerce

bar :: Monad m => m [B]
bar = do
      _ <- pure []
      pure $ over (mapped %% ba) inner []
    where
      -- NB: inlining inner hides the bug
      inner = over aunit id

class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d

class Mapping p where
  -- Uncommenting this line avoids the OOM
  --wibble :: p i a b -> ()
  roam :: ((a -> b) -> s -> t) -> p i a b -> p i s t

first'  :: Mapping p => p i a b -> p i (a, c) (b, c)
first' = roam (\f (a, x) -> (f a, x))

-----
-- Some minimised code originating from optics-core and indexed-profunctors follows

newtype Optic (k :: OpticKind) s t a b
  = Optic (forall p i. (Profunctor p, Constraints k p) => p i a b -> p i s t)

castOptic :: forall s t a b.  Optic A_Lens  s t a b -> Optic A_Setter s t a b
castOptic (Optic o) = Optic o

infixl 9 %%
(%%) :: forall s t u v a b.  Optic A_Setter s t u v -> Optic A_Setter u v a b -> Optic A_Setter s t a b
Optic o %% Optic o' = Optic (o . o')

over
  :: forall s t a b.  Optic A_Setter s t a b -> (a -> b) -> s -> t
over (Optic o) f = runFunArrow $ o (FunArrow f)

lens :: (s -> a) -> (s -> b -> t) -> Optic A_Lens s t a b
lens get set = Optic $ dimap (\s -> (get s, s)) (\(b, s) -> set s b) . first'

mapped :: Functor f => Optic A_Setter (f a) (f b) a b
mapped = Optic (roam fmap)

type OpticKind = Type

data A_Lens :: OpticKind
data A_Setter :: OpticKind

-- Changing this into a synonym hides the OOM bug
type family Constraints (k :: OpticKind) (p :: Type -> Type -> Type -> Type) :: Constraint where
  Constraints A_Lens   p = Mapping p
  Constraints A_Setter p = Mapping p

data Market a b i s t = Market (b -> t) (s -> Either t a)

instance Profunctor (Market a b) where
  dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

-- NB: changing this to data hides the OOM bug
newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b }

instance Profunctor FunArrow where
  dimap f g (FunArrow k) = FunArrow (g . k . f)

instance Mapping FunArrow where
  --wibble _ = ()
  roam  f (FunArrow k) = FunArrow $ f k