diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ CHANGELOG +2.0.2.1 to 2.0.2.2 + + - Restored support for GHC 7.4. + 2.0.2 to 2.0.2.1 - Support for GHC 7.10 by widening TH dependencies. diff --git a/fclabels.cabal b/fclabels.cabal --- a/fclabels.cabal +++ b/fclabels.cabal @@ -1,5 +1,5 @@ Name: fclabels -Version: 2.0.2.1 +Version: 2.0.2.2 Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher with lots of help and feedback from others. Synopsis: First class accessor labels implemented as lenses. @@ -47,9 +47,9 @@ See "Data.Label.Base" and "Data.Label.Monadic" for more information. . - * /Changelog from 2.0.2 to 2.0.2.1/ + * /Changelog from 2.0.2.1 to 2.0.2.2/ . - > - Support for GHC 7.10 by widening TH dependencies. + > - Restored support for GHC 7.4. Maintainer: Sebastiaan Visser Homepage: https://github.com/sebastiaanvisser/fclabels @@ -57,7 +57,7 @@ License: BSD3 License-File: LICENSE Category: Data, Lenses -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple Extra-Source-Files: CHANGELOG @@ -87,3 +87,15 @@ Type: git Location: git://github.com/sebastiaanvisser/fclabels.git +Test-Suite suite + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: TestSuite.hs + Ghc-Options: -Wall -fhpc -threaded + Build-Depends: + base < 5 + , fclabels + , template-haskell >= 2.2 && < 2.11 + , mtl >= 1.0 && < 2.3 + , transformers >= 0.2 && < 0.5 + , HUnit >= 1.2 && < 1.3 diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs --- a/src/Data/Label/Derive.hs +++ b/src/Data/Label/Derive.hs @@ -538,7 +538,11 @@ typeFromBinder :: TyVarBndr -> Type typeFromBinder (PlainTV tv ) = VarT tv +#if MIN_VERSION_template_haskell(2,8,0) typeFromBinder (KindedTV tv StarT) = VarT tv +#else +typeFromBinder (KindedTV tv StarK) = VarT tv +#endif typeFromBinder (KindedTV tv kind ) = SigT (VarT tv) kind binderFromType :: Type -> [TyVarBndr] @@ -626,5 +630,3 @@ = do tysl <- sequence tys return (foldl AppT (ConT cla) tysl) #endif - - diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,526 @@ +{- OPTIONS -ddump-splices #-} + +{-# LANGUAGE + NoMonomorphismRestriction + , KindSignatures + , GADTs + , TemplateHaskell + , TypeOperators + , RankNTypes + , FlexibleContexts #-} + +module Main where + +import Control.Arrow +import Control.Applicative +import Control.Category +import Prelude hiding ((.), id) +import Test.HUnit +import Data.Label +import Data.Label.Derive (defaultNaming, mkLabelsWith) +import Data.Label.Mono ((:~>)) +import Data.Label.Failing (Failing) +import Data.Tuple (swap) + +import Control.Monad.Reader (runReader) +import Control.Monad.State (evalState, execState, runState) + +import qualified Data.Label.Base as L +import qualified Data.Label.Failing as Failing +import qualified Data.Label.Mono as Mono +import qualified Data.Label.Partial as Partial +import qualified Data.Label.Poly as Poly +import qualified Data.Label.Total as Total +import qualified Data.Label.Monadic as Monadic + +------------------------------------------------------------------------------- + +data NoRecord = NoRecord Integer Bool + deriving (Eq, Ord, Show) + +mkLabel ''NoRecord + +fclabels [d| + newtype Newtype a = Newtype { unNewtype :: [a] } + deriving (Eq, Ord, Show) + |] + +newtypeL :: ArrowApply cat => Poly.Lens cat (Newtype a -> Newtype b) ([a] -> [b]) +newtypeL = unNewtype + +data Record = Record + { _fA :: Integer + , _fB :: Maybe (Newtype Bool) + , _fC :: Newtype Bool + , _fD :: Either Integer Bool + } deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming False False False False ''Record + +fD :: ArrowApply cat => Mono.Lens cat (Record) (Either Integer Bool) +fC :: ArrowApply cat => Mono.Lens cat (Record) (Newtype Bool) +fB :: ArrowApply cat => Mono.Lens cat (Record) (Maybe (Newtype Bool)) +fA :: ArrowApply cat => Mono.Lens cat (Record) (Integer) + +data Multi + = First { _mA :: Record + , _mB :: Double + , _mC :: Either String Float + } + | Second { _mB :: Double } + deriving (Eq, Ord, Show) + +mkLabels [''Multi] + +data View = View + { _vA :: Maybe (Newtype Bool) + , _vB :: Either Integer Bool + , _vC :: Newtype Bool + } deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming True True False False ''View + +data Direction i a b c d + = North { _dir :: i, _north :: a } + | East { _dir :: i, _east :: b } + | South { _dir :: i, _south :: c } + | West { _dir :: i, _west :: d } + | All { _dir :: i, _allDirs :: (a, b, c, d) } + deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming True False True True ''Direction + +-- Higher kinded type variable, requires KindSignatures. + +data Fa f a = Fa { fa :: f a } + +mkLabel ''Fa + +------------------------------------------------------------------------------- + +data Gadt a where + C1 :: { ga :: Integer, gb :: Bool } -> Gadt (Int, Bool) + C2 :: { gc :: Integer, gd :: Maybe Bool } -> Gadt Bool + C3 :: { ge :: a, gf :: b } -> Gadt (a, b) + C4 :: { gg :: a } -> Gadt [a] + C5 :: { gd :: Maybe Bool } -> Gadt Bool + C6 :: { gh :: [a] } -> Gadt (a, a, a) + +mkLabel ''Gadt + +_Ga :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Integer +_Gb :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Bool +_Gc :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt Bool) Integer +_Gd :: (ArrowApply cat ) => Mono.Lens cat (Gadt Bool) (Maybe Bool) +_Ge :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (c, b)) (a -> c) +_Gf :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (a, c)) (b -> c) +_Gg :: (ArrowApply cat ) => Poly.Lens cat (Gadt [a] -> Gadt [b]) (a -> b) +_Gh :: (ArrowApply cat ) => Poly.Lens cat (Gadt (a, a, a) -> Gadt (b, b, b)) ([a] -> [b]) + +_Ga = lGa; _Gb = lGb; _Gc = lGc; _Gd = lGd; _Ge = lGe; _Gf = lGf; _Gg = lGg; _Gh = lGh; + +------------------------------------------------------------------------------- + +embed_fB :: Record :~> Newtype Bool +embed_fB = Partial.embed fB + +manual_fA :: Record :-> Integer +manual_fA = Total.lens _fA (\m f -> f { _fA = m (_fA f) }) + +manual_fA_m :: Mono.Lens (->) Record Integer +manual_fA_m = lens _fA (\m f -> f { _fA = m (_fA f) }) + +manual_mA :: Multi :~> Record +manual_mA = Partial.lens + (\p -> case p of First {} -> Just (_mA p); _ -> Nothing) + (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Nothing) + +mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) +mA_f = mA + +manual_mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) +manual_mA_f = Failing.lens + (\p -> case p of First {} -> Right (_mA p); _ -> Left "mA") + (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Left "mA") + +embed_fD :: Failing.Lens Integer (Record -> Record) (Bool -> Bool) +embed_fD = Failing.embed fD + +manual_dir :: Poly.Lens (->) (Direction i a b c d -> Direction e a b c d) (i -> e) +manual_dir = Poly.lens _dir (\(m, f) -> f {_dir = m (_dir f) }) + +north_f :: Poly.Lens (Failing String) (Direction i a b c d -> Direction i e b c d) (a -> e) +north_f = north + +fAmA :: Multi :~> Integer +fAmA = fA . mA + +recordView :: Record :-> View +recordView = Poly.point $ + View <$> vA >- fB + <*> vB >- fD + <*> vC >- fC + +newtypeId :: Newtype Bool :-> Newtype Bool +newtypeId = Poly.point (id <$> id >- id) + +------------------------------------------------------------------------------- + +fclabels [d| + + data View2 a + = Con1 { field1 :: Bool + , field2 :: (a, a) + } + | Con2 { field1 :: Bool + , field3 :: [a] + } + deriving (Eq, Show) + + |] + +view :: View2 a :~> Either (Bool, (a, a)) (Bool, [a]) +view = point $ + Left <$> L.left >- con1 + <|> Right <$> L.right >- con2 + where con1 = point $ + (,) <$> L.fst >- field1 + <*> L.snd >- field2 + con2 = point $ + (,) <$> L.fst >- field1 + <*> L.snd >- field3 + +------------------------------------------------------------------------------- +-- Test data type with large number (> 26) of fields. + +fclabels [d| + + data C = C { c_a :: (), c_b :: (), c_c :: (), c_d :: (), c_e :: (), c_f :: () + , c_g :: (), c_h :: (), c_i :: (), c_j :: (), c_k :: (), c_l :: () + , c_m :: (), c_n :: (), c_o :: (), c_p :: (), c_q :: (), c_r :: () + , c_s :: (), c_t :: (), c_u :: (), c_v :: (), c_w :: (), c_x :: () + , c_y :: (), c_z :: (), c_a0 :: (), c_b0 :: (), c_c0 :: (), c_d0 :: () + } + + |] + +------------------------------------------------------------------------------- + +newtype0, newtype1, newtype2 :: Newtype Bool +newtype0 = Newtype [] +newtype1 = Newtype [True] +newtype2 = Newtype [False] + +record0, record1, record2, record3, record4, record5, record10, record11 :: Record +record0 = Record 0 Nothing newtype0 (Left 1) +record1 = Record 1 Nothing newtype0 (Left 1) +record2 = Record 0 (Just newtype1) newtype0 (Left 1) +record3 = Record 0 (Just newtype0) newtype0 (Left 1) +record4 = Record 0 Nothing newtype0 (Right True) +record5 = Record 0 Nothing newtype0 (Right False) +record10 = Record 10 Nothing newtype0 (Left 1) +record11 = Record 11 Nothing newtype0 (Left 1) + +first0, first1, first2 :: Multi +first0 = First record0 0.0 (Right 1.0) +first1 = First record0 1.0 (Right 1.0) +first2 = First record1 0.0 (Right 1.0) + +second0, second1 :: Multi +second0 = Second 0.0 +second1 = Second 1.0 + +north0 :: Direction Integer () () () () +north0 = North 0 () + +north1 :: Direction Bool () () () () +north1 = North False () + +north2 :: Direction Integer Bool () () () +north2 = North 0 False + +west0 :: Direction Integer () () () () +west0 = West 0 () + +mulDiv :: Iso (->) Integer Double +mulDiv = Iso (\i -> fromInteger i / 10) (\i -> round (i * 10)) + +addSub :: Iso (->) Double Integer +addSub = Iso (\i -> round (i + 10)) (\i -> fromInteger i - 10) + +------------------------------------------------------------------------------- + +main :: IO () +main = + do _ <- runTestTT allTests + return () + +allTests :: Test +allTests = TestList + [ mono + , totalMono + , partialMono + , failingMono + , totalPoly + , partialPoly + , failingPoly + , composition + , applicativeTotal + , applicativePartial + , bijections + , monadic + , base + ] + +mono :: Test +mono = TestList + [ eq "get manual_fA_m" (get manual_fA_m record0) 0 + , eq "set manual_fA_m" (set manual_fA_m 1 record0) record1 + , eq "mod manual_fA_m" (modify manual_fA_m (+ 1) record0) record1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +totalMono :: Test +totalMono = TestList + [ eq "get fA" (Total.get fA record0) 0 + , eq "set fA" (Total.set fA 1 record0) record1 + , eq "mod fA" (Total.modify fA (+ 1) record0) record1 + , eq "get manual_fA" (Total.get manual_fA record0) 0 + , eq "set manual_fA" (Total.set manual_fA 1 record0) record1 + , eq "mod manual_fA" (Total.modify manual_fA (+ 1) record0) record1 + , eq "get mB" (Total.get mB first0) 0 + , eq "set mB" (Total.set mB 1 first0) first1 + , eq "mod mB" (Total.modify mB (+ 1) first0) first1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +partialMono :: Test +partialMono = TestList + [ eq0 "get mA" (Partial.get mA first0) (Just record0) + , eq0 "set mA" (Partial.set mA record1 first0) (Just first2) + , eq0 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) first0) (Just first2) + , eq0 "get manual_mA" (Partial.get manual_mA first0) (Just record0) + , eq0 "set manual_mA" (Partial.set manual_mA record1 first0) (Just first2) + , eq0 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) first0) (Just first2) + , eq1 "get mA" (Partial.get mA second0) Nothing + , eq1 "set mA" (Partial.set mA record1 second0) Nothing + , eq1 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) second0) Nothing + , eq1 "get manual_mA" (Partial.get manual_mA second0) Nothing + , eq1 "set manual_mA" (Partial.set manual_mA record1 second0) Nothing + , eq1 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) second0) Nothing + , eq2 "set mA" (Partial.set' mA record1 first0) first2 + , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) first0) first2 + , eq2 "set manual_mA" (Partial.set' manual_mA record1 first0) first2 + , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) first0) first2 + , eq2 "set mA" (Partial.set' mA record1 second0) second0 + , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) second0) second0 + , eq2 "set manual_mA" (Partial.set' manual_mA record1 second0) second0 + , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) second0) second0 + , eq3 "get embed_fB" (Partial.get embed_fB record2) (Just newtype1) + , eq3 "set embed_fB" (Partial.set embed_fB newtype0 record2) (Just record3) + , eq3 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record2) (Just record3) + , eq4 "get embed_fB" (Partial.get embed_fB record0) Nothing + , eq4 "set embed_fB" (Partial.set embed_fB newtype0 record0) Nothing + , eq4 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record0) Nothing + ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("partial mono " ++ x) + eq1 x = equality ("partial mono fail " ++ x) + eq2 x = equality ("partial mono prime " ++ x) + eq3 x = equality ("partial mono embed " ++ x) + eq4 x = equality ("partial mono embed fail" ++ x) + +failingMono :: Test +failingMono = TestList + [ eq0 "get mA_f" (Failing.get mA_f first0) (Right record0) + , eq0 "set mA_f" (Failing.set mA_f record1 first0) (Right first2) + , eq0 "mod mA_f" (Failing.modify mA_f (Total.modify fA (+ 1)) first0) (Right first2) + , eq0 "get manual_mA_f" (Failing.get manual_mA_f first0) (Right record0) + , eq0 "set manual_mA_f" (Failing.set manual_mA_f record1 first0) (Right first2) + , eq0 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) first0) (Right first2) + , eq1 "get mA_f fail" (Failing.get mA_f second0) (Left "") + , eq1 "set mA_f fail" (Failing.set mA_f record1 second0) (Left "") + , eq1 "mod mA_f fail" (Failing.modify mA_f (Total.modify fA (+ 1)) second0) (Left "") + , eq1 "get manual_mA_f" (Failing.get manual_mA_f second0) (Left "mA") + , eq1 "set manual_mA_f" (Failing.set manual_mA_f record1 second0) (Left "mA") + , eq1 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) second0) (Left "mA") + , eq2 "set mA_f" (Failing.set' mA_f record1 first0) first2 + , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) first0) first2 + , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 first0) first2 + , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) first0) first2 + , eq2 "set mA_f" (Failing.set' mA_f record1 second0) second0 + , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) second0) second0 + , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 second0) second0 + , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) second0) second0 + , eq3 "get embed_fD" (Failing.get embed_fD record4) (Right True) + , eq3 "set embed_fD" (Failing.set embed_fD False record4) (Right record5) + , eq3 "mod embed_fD" (Failing.modify embed_fD not record4) (Right record5) + , eq4 "get embed_fD" (Failing.get embed_fD record0) (Left 1) + , eq4 "set embed_fD" (Failing.set embed_fD False record0) (Left 1) + , eq4 "mod embed_fD" (Failing.modify embed_fD not record0) (Left 1) + ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("failing mono " ++ x) + eq1 x = equality ("failing mono fail " ++ x) + eq2 x = equality ("failing mono prime " ++ x) + eq3 x = equality ("failing mono embed " ++ x) + eq4 x = equality ("failing mono embed fail " ++ x) + +totalPoly :: Test +totalPoly = TestList + [ eq "get dir" (Total.get dir north0) (0 :: Integer) + , eq "set dir" (Total.set dir False north0) north1 + , eq "mod dir" (Total.modify dir (> 1) north0) north1 + , eq "get manual_dir" (Total.get manual_dir north0) 0 + , eq "set manual_dir" (Total.set manual_dir False north0) north1 + , eq "mod manual_dir" (Total.modify manual_dir (> 1) north0) north1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +partialPoly :: Test +partialPoly = TestList + [ eq0 "get north" (Partial.get north north0) (Just ()) + , eq0 "set north" (Partial.set north False north0) (Just north2) + , eq0 "mod north" (Partial.modify north (> ()) north0) (Just north2) + , eq1 "get north" (Partial.get north west0) Nothing + , eq1 "set north" (Partial.set north False west0) Nothing + , eq1 "mod north" (Partial.modify north (> ()) west0) Nothing + ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("partial poly " ++ x) + eq1 x = equality ("partial poly fail " ++ x) + +failingPoly :: Test +failingPoly = TestList + [ eq0 "get north" (Failing.get north_f north0) (Right ()) + , eq0 "set north" (Failing.set north_f False north0) (Right north2) + , eq0 "mod north" (Failing.modify north_f (> ()) north0) (Right north2) + , eq1 "get north" (Failing.get north_f west0) (Left "north") + , eq1 "set north" (Failing.set north_f False west0) (Left "north") + , eq1 "mod north" (Failing.modify north_f (> ()) west0) (Left "north") + ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("failing poly " ++ x) + eq1 x = equality ("failing poly fail " ++ x) + +composition :: Test +composition = TestList + [ eq0 "get id" (Partial.get id first0) (Just first0) + , eq0 "set id" (Partial.set id first2 first0) (Just first2) + , eq0 "mod id" (Partial.modify id (const first2) first0) (Just first2) + , eq0 "get fAmA" (Partial.get fAmA first0) (Just 0) + , eq0 "set fAmA" (Partial.set fAmA 1 first0) (Just first2) + , eq0 "mod fAmA" (Partial.modify fAmA (+ 1) first0) (Just first2) + , eq0 "get id fAmA" (Partial.get (id . fAmA) first0) (Just 0) + , eq0 "set id fAmA" (Partial.set (id . fAmA) 1 first0) (Just first2) + , eq0 "mod id fAmA" (Partial.modify (id . fAmA) (+ 1) first0) (Just first2) + , eq0 "get fAmA id" (Partial.get (fAmA . id) first0) (Just 0) + , eq0 "set fAmA id" (Partial.set (fAmA . id) 1 first0) (Just first2) + , eq0 "mod fAmA id" (Partial.modify (fAmA . id) (+ 1) first0) (Just first2) + ] where eq0 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("composition partial mono" ++ x) + +applicativeTotal :: Test +applicativeTotal = TestList + [ eq "get vA" (Total.get (vA . recordView) record0) Nothing + , eq "get vB" (Total.get (vB . recordView) record0) (Left 1) + , eq "get vC" (Total.get (vC . recordView) record0) newtype0 + , eq "set vA" (Total.set (vA . recordView) (Just newtype0) record2) record3 + , eq "modify vA" (Total.modify (vA . recordView) (fmap (const newtype0)) record2) record3 + + , eq "get newtypeId" (Total.get newtypeId newtype0) newtype0 + , eq "set newtypeId" (Total.set newtypeId newtype1 newtype0) newtype1 + , eq "mod newtypeId" (Total.modify newtypeId (const newtype2) newtype0) newtype2 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("applicative total mono" ++ x) + +myCon1 :: View2 Char +myCon1 = Con1 False ('a', 'z') + +myCon2 :: View2 Char +myCon2 = Con2 True "abc" + +applicativePartial :: Test +applicativePartial = TestList + [ eq "get" (Partial.get (L.snd . L.left . view) myCon1) (Just ('a', 'z')) + , eq "get" (Partial.get (L.snd . L.left . view) myCon2) Nothing + , eq "get" (Partial.get (L.snd . L.right . view) myCon1) Nothing + , eq "get" (Partial.get (L.snd . L.right . view) myCon2) (Just "abc") + , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon1) (Just (Con1 True ('a', 'z'))) + , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon2) Nothing + , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon1) Nothing + , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon2) (Just (Con2 False "abc")) + , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon1) (Just (Con1 False ('z', 'a'))) + , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon2) Nothing + , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon1) Nothing + , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon2) (Just (Con2 True "cba")) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("applicative partial mono" ++ x) + +bijections :: Test +bijections = TestList + [ eq "get mulDiv" (get (iso mulDiv . fA) record0) 0 + , eq "set mulDiv" (set (iso mulDiv . fA) 1 record0) record10 + , eq "mod mulDiv" (modify (iso mulDiv . fA) (+ 1) record0) record10 + , eq "get addSub" (get (iso (inv addSub) . fA) record0) (-10) + , eq "set addSub" (set (iso (inv addSub) . fA) 1 record0) record11 + , eq "mod addSub" (modify (iso (inv addSub) . fA) (+ 1) record0) record1 + + , eq "get id mulDiv" (get (iso (id . mulDiv) . fA) record0) 0 + , eq "set id mulDiv" (set (iso (id . mulDiv) . fA) 1 record0) record10 + , eq "mod id mulDiv" (modify (iso (id . mulDiv) . fA) (+ 1) record0) record10 + , eq "get id mulDiv" (get (iso (mulDiv . id) . fA) record0) 0 + , eq "set id mulDiv" (set (iso (mulDiv . id) . fA) 1 record0) record10 + , eq "mod id mulDiv" (modify (iso (mulDiv . id) . fA) (+ 1) record0) record10 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("isomorphisms mono " ++ x) + +monadic :: Test +monadic = TestList + [ eq "asks id total" (runReader (Monadic.asks id) record0) record0 + , eq "asks fC total" (runReader (Monadic.asks fC) record0) newtype0 + , eq "gets id total" (evalState (Monadic.gets id) record0) record0 + , eq "gets fC total" (evalState (Monadic.gets fC) record0) newtype0 + + , eq "put fA total" (execState (fA Monadic.=: 1) record0) record1 + , eq "modify fA total" (execState (fA Monadic.=. (+ 1)) record0) record1 + + , eq "local fA total" (runReader (Monadic.local fA (+1) $ Monadic.asks id) record0) record1 + , eq "modifyAndGet fA total" (runState (Monadic.modifyAndGet fA (\a -> (a+10, a+1))) record0) (10, record1) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total monadic " ++ x) + +base :: Test +base = TestList + [ eq "get head" (Partial.get L.head [1, 2, 3]) (Just (1::Int)) + , eq "get head" (Partial.get L.head ([] :: [Int])) Nothing + , eq "get tail" (Partial.get L.tail [1, 2, 3]) (Just [2, 3 ::Int]) + , eq "get tail" (Partial.get L.tail ([] :: [Int])) Nothing + , eq "get left" (Partial.get L.left (Left 'a')) (Just 'a') + , eq "get left" (Partial.get L.left (Right 'a' :: Either () Char)) Nothing + , eq "get right" (Partial.get L.right (Right 'a')) (Just 'a') + , eq "get right" (Partial.get L.right (Left 'a' :: Either Char ())) Nothing + , eq "get just" (Partial.get L.just (Just 'a')) (Just 'a') + , eq "get just" (Partial.get L.just (Nothing :: Maybe Char)) Nothing + , eq "get fst" (Total.get (L.fst . L.swap) ('a', ())) () + , eq "get snd" (Total.get (L.snd . L.swap) ((), 'b')) () + , eq "get fst3" (Total.get L.fst3 ('a', (), ())) 'a' + , eq "get snd3" (Total.get L.snd3 ((), 'b', ())) 'b' + , eq "get trd3" (Total.get L.trd3 ((), (), 'c')) 'c' + , eq "mod head" (Partial.modify L.head (*2) [1, 2, 3]) (Just [2, 2, 3::Int]) + , eq "mod head" (Partial.modify L.head (*2) ([]::[Int])) Nothing + , eq "mod tail" (Partial.modify L.tail reverse [1, 2, 3]) (Just [1, 3, 2::Int]) + , eq "mod tail" (Partial.modify L.tail reverse ([]::[Int])) Nothing + , eq "mod left" (Partial.modify L.left (=='a') (Left 'a')) (Just (Left True :: Either Bool ())) + , eq "mod left" (Partial.modify L.left (=='a') (Right ())) (Nothing :: Maybe (Either Bool ())) + , eq "mod right" (Partial.modify L.right (=='c') (Right 'b')) (Just (Right False :: Either () Bool)) + , eq "mod right" (Partial.modify L.right (=='c') (Left ())) (Nothing :: Maybe (Either () Bool)) + , eq "mod just" (Partial.modify L.just (=='a') (Just 'a')) (Just (Just True)) + , eq "mod just" (Partial.modify L.just (=='a') Nothing) Nothing + , eq "mod fst" (Total.modify (L.fst . L.swap) (== 'a') ((), 'a')) ((), True) + , eq "mod snd" (Total.modify (L.snd . L.swap) (== 'a') ('a', ())) (True, ()) + , eq "mod fst3" (Total.modify L.fst3 (== 'a') ('a', (), ())) (True, (), ()) + , eq "mod snd3" (Total.modify L.snd3 (== 'a') ((), 'b', ())) ((), False, ()) + , eq "mod trd3" (Total.modify L.trd3 (== 'a') ((), (), 'c')) ((), (), False) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("base" ++ x) + +equality :: (Eq a, Show a) => String -> a -> a -> Test +equality d a b = TestCase (assertEqual d b a) +