git.iko.soy/generic-lens
on master help sign in
Two more prism tests
2cbc1e8Matthew Pickering
test/Spec.hs+21−1
compare with master
unifiedsplit
@@ -10,7 +10,7 @@
10{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TemplateHaskell #-}
12-- For the VL prism test
12-- For the VL prism test
13−{-# OPTIONS_GHC -funfolding-use-threshold=100 #-}
13+{-# OPTIONS_GHC -funfolding-use-threshold=1000 #-}
14
14
15module Main where
15module Main where
16
16
@@ -106,6 +106,7 @@ subtypeLensManual f record
106 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
106 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
107
107
108data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
108data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
109+data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
109
110
110sum1PrismManual :: Prism Sum1 Sum1 Int Int
111sum1PrismManual :: Prism Sum1 Sum1 Int Int
111sum1PrismManual eta = prism g f eta
112sum1PrismManual eta = prism g f eta
@@ -123,6 +124,17 @@ sum1PrismPManual eta = prismP g f eta
123 s -> Left s
124 s -> Left s
124 g = B
125 g = B
125
126
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+
126
138
127--------------------------------------------------------------------------------
139--------------------------------------------------------------------------------
128-- * Tests
140-- * Tests
@@ -158,6 +170,12 @@ sum1PrismB = _Ctor @"B"
158sum1PrismBP :: PrismP Sum1 Sum1 Int Int
170sum1PrismBP :: PrismP Sum1 Sum1 Int Int
159sum1PrismBP = prismPRavel (_CtorRaw @"B")
171sum1PrismBP = prismPRavel (_CtorRaw @"B")
160
172
173+subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
174+subtypePrismGeneric = _Sub
175+
176+sum1TypePrism :: Prism Sum1 Sum1 Int Int
177+sum1TypePrism = _Typed @Int
178+
161inspect $ 'fieldALensManual === 'fieldALensName
179inspect $ 'fieldALensManual === 'fieldALensName
162inspect $ 'fieldALensManual === 'fieldALensType
180inspect $ 'fieldALensManual === 'fieldALensType
163inspect $ 'fieldALensManual === 'fieldALensPos
181inspect $ 'fieldALensManual === 'fieldALensPos
@@ -168,5 +186,7 @@ inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
168inspect $ 'intTraversalManual === 'intTraversalDerived
186inspect $ 'intTraversalManual === 'intTraversalDerived
169inspect $ 'sum1PrismManual === 'sum1PrismB
187inspect $ 'sum1PrismManual === 'sum1PrismB
170inspect $ 'sum1PrismPManual === 'sum1PrismBP
188inspect $ 'sum1PrismPManual === 'sum1PrismBP
189+inspect $ 'subtypePrismManual === 'subtypePrismGeneric
190+inspect $ 'sum1PrismManual === 'sum1TypePrism
171
191
172
192