@@ -10,7 +10,7 @@
1010{-# LANGUAGE TypeApplications #-}
1111{-# LANGUAGE TemplateHaskell #-}
1212-- For the VL prism test
13−{-# OPTIONS_GHC -funfolding-use-threshold=100 #-}
13+{-# OPTIONS_GHC -funfolding-use-threshold=1000 #-}
1414
1515module Main where
1616
@@ -106,6 +106,7 @@ subtypeLensManual f record
106106 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
107107
108108data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
109+data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
109110
110111sum1PrismManual :: Prism Sum1 Sum1 Int Int
111112sum1PrismManual eta = prism g f eta
@@ -123,6 +124,17 @@ sum1PrismPManual eta = prismP g f eta
123124 s -> Left s
124125 g = B
125126
127+subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
128+subtypePrismManual eta = prism g f eta
129+ where
130+ f s1 = case s1 of
131+ A c -> Right (A2 c)
132+ B i -> Right (B2 i)
133+ C _ -> Left s1
134+ D _ -> Left s1
135+ g (A2 c) = A c
136+ g (B2 i) = B i
137+
126138
127139--------------------------------------------------------------------------------
128140-- * Tests
@@ -158,6 +170,12 @@ sum1PrismB = _Ctor @"B"
158170sum1PrismBP :: PrismP Sum1 Sum1 Int Int
159171sum1PrismBP = prismPRavel (_CtorRaw @"B")
160172
173+subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
174+subtypePrismGeneric = _Sub
175+
176+sum1TypePrism :: Prism Sum1 Sum1 Int Int
177+sum1TypePrism = _Typed @Int
178+
161179inspect $ 'fieldALensManual === 'fieldALensName
162180inspect $ 'fieldALensManual === 'fieldALensType
163181inspect $ 'fieldALensManual === 'fieldALensPos
@@ -168,5 +186,7 @@ inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
168186inspect $ 'intTraversalManual === 'intTraversalDerived
169187inspect $ 'sum1PrismManual === 'sum1PrismB
170188inspect $ 'sum1PrismPManual === 'sum1PrismBP
189+inspect $ 'subtypePrismManual === 'subtypePrismGeneric
190+inspect $ 'sum1PrismManual === 'sum1TypePrism
171191
172192