70d9f28 · generic-lens

git.iko.soy/generic-lens

on master help sign in

Fix subtype Prism

70d9f28Csongor Kiss9 years ago

src/Data/Generics/Internal/Families/Has.hs+2

compare with master

unifiedsplit

@@ -84,6 +84,8 @@ type family HasPartialTypeP a f :: Bool where

84 = HasPartialTypeP t l || HasPartialTypeP t r

85 HasPartialTypeP t (C1 m f)

86 = t == GTypes f

87+ HasPartialTypeP t (M1 _ _ f)

88+ = HasPartialTypeP t f

87 HasPartialTypeP t _

89 HasPartialTypeP t _

88 = 'False

90 = 'False

src/Data/Generics/Internal/Profunctor/Prism.hs+7

@@ -22,6 +22,7 @@

22module Data.Generics.Internal.Profunctor.Prism where

24import Data.Profunctor (Choice(..), Profunctor(..))

25+import Data.Tagged

25import Data.Profunctor.Unsafe ((#.), (.#))

26import Data.Profunctor.Unsafe ((#.), (.#))

26import GHC.Generics

27import GHC.Generics

27import Data.Coerce

28import Data.Coerce

@@ -51,6 +52,12 @@ _Right = prism Right $ either (Left . Left) Right

51prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b

52prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b

52prismPRavel l pab = (prism2prismp $ l idPrism) pab

53prismPRavel l pab = (prism2prismp $ l idPrism) pab

55+build :: (Tagged b b -> Tagged t t) -> b -> t

56+build p = unTagged #. p .# Tagged

57+

58+match :: Prism s t a b -> s -> Either t a

59+match k = withPrism k $ \_ _match -> _match

60+

54--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

55-- Prism stuff

62-- Prism stuff

src/Data/Generics/Internal/VL/Prism.hs+3−1

@@ -44,9 +44,11 @@ s ^? l = getFirst (fmof l (First #. Just) s)

45match :: Prism s t a b -> s -> Either t a

46match k = withPrism k $ \_ _match -> _match

47+{-# INLINE match #-}

48(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t

49(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t

49(#) = build

50(#) = build

51+{-# INLINE (#) #-}

51prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

53prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

52prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

54prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

@@ -68,4 +70,4 @@ prism2prismvl (Market bt seta) = prism bt seta

69build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t

71build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t

70build p = runIdentity #. unTagged #. p .# Tagged .# Identity

72build p = runIdentity #. unTagged #. p .# Tagged .# Identity

71−

73+{-# INLINE build #-}

src/Data/Generics/Sum/Internal/Subtype.hs+66−14

@@ -1,9 +1,10 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

1−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE KindSignatures #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

@@ -34,6 +35,7 @@ import Data.Kind

34import GHC.Generics

35import GHC.Generics

35import Data.Generics.Internal.Profunctor.Iso

36import Data.Generics.Internal.Profunctor.Iso

36import Data.Generics.Internal.Profunctor.Prism

37import Data.Generics.Internal.Profunctor.Prism

38+import Data.Generics.Internal.Families.Has

38-- |As 'AsSubtype' but over generic representations as defined by

40-- |As 'AsSubtype' but over generic representations as defined by

39-- "GHC.Generics".

41-- "GHC.Generics".

@@ -41,22 +43,72 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where

41 _GSub :: Prism' (supf x) (subf x)

43 _GSub :: Prism' (supf x) (subf x)

43instance

45instance

44− ( GAsSubtype l supf

46+ ( GSplash sub sup

45− , GAsSubtype r supf

47+ , GDowncast sub sup

46− ) => GAsSubtype (l :+: r) supf where

48+ ) => GAsSubtype sub sup where

47− _GSub = without' _GSub _GSub . fromIso sumIso

49+ _GSub f = prismPRavel (prism _GSplash _GDowncast) f

48 {-# INLINE _GSub #-}

50 {-# INLINE _GSub #-}

52+--------------------------------------------------------------------------------

53+

54+class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where

55+ _GSplash :: sub x -> sup x

56+

57+instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where

58+ _GSplash (L1 rep) = _GSplash rep

59+ _GSplash (R1 rep) = _GSplash rep

60+ {-# INLINE _GSplash #-}

61+

50instance

62instance

51 ( GIsList () subf subf as as

63 ( GIsList () subf subf as as

52 , GAsType supf as

64 , GAsType supf as

53− ) => GAsSubtype (C1 meta subf) supf where

65+ ) => GSplash (C1 meta subf) supf where

54− _GSub = _GTyped . fromIso (glist @()) . fromIso mIso

66+ _GSplash p = build (prismPRavel (_GTyped . fromIso (glist @()) . fromIso mIso)) p

55− {-# INLINE _GSub #-}

67+ {-# INLINE _GSplash #-}

57−-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where

69+instance GSplash sub sup => GSplash (D1 c sub) sup where

58−-- _GSub = _GTyped . fromIso (mIso . kIso)

70+ _GSplash (M1 m) = _GSplash m

71+ {-# INLINE _GSplash #-}

60−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where

73+--------------------------------------------------------------------------------

61− _GSub = _GSub . fromIso mIso

74+

75+class GDowncast sub sup where

76+ _GDowncast :: sup x -> Either (sup x) (sub x)

77+

78+instance

79+ ( GIsList () sup sup as as

80+ , GDowncastC (HasPartialTypeP as sub) sub sup

81+ ) => GDowncast sub (C1 m sup) where

82+ _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of

83+ Left _ -> Left (M1 m)

84+ Right r -> Right r

85+ {-# INLINE _GDowncast #-}

86+

87+instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where

88+ _GDowncast (L1 x) = case _GDowncast x of

89+ Left _ -> Left (L1 x)

90+ Right r -> Right r

91+ _GDowncast (R1 x) = case _GDowncast x of

92+ Left _ -> Left (R1 x)

93+ Right r -> Right r

94+ {-# INLINE _GDowncast #-}

95+

96+instance GDowncast sub sup => GDowncast sub (D1 m sup) where

97+ _GDowncast (M1 m) = case _GDowncast m of

98+ Left _ -> Left (M1 m)

99+ Right r -> Right r

100+ {-# INLINE _GDowncast #-}

101+

102+class GDowncastC (contains :: Bool) sub sup where

103+ _GDowncastC :: sup x -> Either (sup x) (sub x)

104+

105+instance GDowncastC 'False sub sup where

106+ _GDowncastC sup = Left sup

107+ {-# INLINE _GDowncastC #-}

108+

109+instance

110+ ( GAsType sub subl

111+ , GIsList () sup sup subl subl

112+ ) => GDowncastC 'True sub sup where

113+ _GDowncastC sup = Right (build (prismPRavel (_GTyped . fromIso (glist @()))) sup)

62− {-# INLINE _GSub #-}

114+ {-# INLINE _GDowncastC #-}

src/Data/Generics/Sum/Subtype.hs+2−1

@@ -1,8 +1,9 @@

1−{-# LANGUAGE TypeApplications #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MonoLocalBinds #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeSynonymInstances #-}

8{-# LANGUAGE TypeSynonymInstances #-}

8{-# LANGUAGE UndecidableInstances #-}

9{-# LANGUAGE UndecidableInstances #-}