585f72b · typeable/schematic

git.iko.soy/typeable/schematic

on master help sign in

Object lenses

585f72bDenis Redozubov9 years ago

schematic.cabal+2

compare with master

unifiedsplit

@@ -18,6 +18,7 @@ cabal-version: >=1.10

18library

19 exposed-modules: Data.Schematic

20 , Data.Schematic.Instances

21+ , Data.Schematic.Lens

21 , Data.Schematic.Migration

22 , Data.Schematic.Migration

22 , Data.Schematic.Path

23 , Data.Schematic.Path

23 , Data.Schematic.Schema

24 , Data.Schematic.Schema

@@ -52,6 +53,7 @@ library

52 , TemplateHaskell

53 , TemplateHaskell

53 , TypeApplications

54 , TypeApplications

54 , TypeFamilies

55 , TypeFamilies

56+ , TypeFamilyDependencies

55 , TypeInType

57 , TypeInType

56 , TypeOperators

58 , TypeOperators

57 , TypeSynonymInstances

59 , TypeSynonymInstances

src/Data/Schematic/Lens.hsnew file+75

@@ -0,0 +1,75 @@

1+{-# LANGUAGE UndecidableSuperClasses #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE InstanceSigs #-}

6+module Data.Schematic.Lens where

8+import Data.Proxy

9+import Data.Schematic.Migration

10+import Data.Schematic.Schema

11+import Data.Vinyl

12+import Data.Vinyl.Functor

13+import Data.Vinyl.TypeLevel (Nat(..))

14+import GHC.TypeLits (Symbol)

15+

16+

17+-- | A partial relation that gives the index of a value in a list.

18+type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where

19+ FIndex r ( '(fn, s) ': rs) = 'Z

20+ FIndex r ( s ': rs) = 'S (FIndex r rs)

21+

22+class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where

23+ type ByRevision fn rs i :: Schema

24+ flens

25+ :: Functor g

26+ => proxy fn

27+ -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))

28+ -> Rec FieldRepr rs

29+ -> g (Rec FieldRepr rs)

30+

31+ -- | For Vinyl users who are not using the @lens@ package, we provide a getter.

32+ fget

33+ :: proxy fn

34+ -> Rec FieldRepr rs

35+ -> FieldRepr '(fn, (ByRevision fn rs i))

36+

37+ -- | For Vinyl users who are not using the @lens@ package, we also provide a

38+ -- setter. In general, it will be unambiguous what field is being written to,

39+ -- and so we do not take a proxy argument here.

40+ fput

41+ :: FieldRepr '(fn, ByRevision fn rs i)

42+ -> Rec FieldRepr rs

43+ -> Rec FieldRepr rs

44+

45+instance FElem fn ('(fn, r) ': rs) 'Z where

46+ type ByRevision fn ('(fn, r) ': rs) 'Z = r

47+ flens _ f (x :& xs) = fmap (:& xs) (f x)

48+ {-# INLINE flens #-}

49+ fget k = getConst . flens k Const

50+ {-# INLINE fget #-}

51+ fput y = getIdentity . flens Proxy (\_ -> Identity y)

52+ {-# INLINE fput #-}

53+

54+instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where

55+ type ByRevision fn (s ': rs) ('S i) = ByRevision fn rs i

56+ flens p f (x :& xs) = fmap (x :&) (flens p f xs)

57+ {-# INLINE flens #-}

58+ fget k = getConst . flens k Const

59+ {-# INLINE fget #-}

60+ fput y = getIdentity . flens Proxy (\_ -> Identity y)

61+ {-# INLINE fput #-}

62+

63+type SchemaExample

64+ = 'SchemaObject

65+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

66+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

67+

68+type TestMigration =

69+ 'Migration "test_revision"

70+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

71+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

72+

73+type VS = 'Versioned SchemaExample '[ TestMigration ]

74+

75+type Ex = FIndex "initial" (AllVersions VS)

src/Data/Schematic/Migration.hs−1

@@ -8,7 +8,6 @@ import Data.Schematic.Path

8import Data.Schematic.Schema

9import Data.Singletons.Prelude hiding (All)

10import Data.Singletons.TypeLits

11−-- import Data.Vinyl hiding (Dict)

14data Path

13data Path

src/Data/Schematic/Schema.hs+24−21

@@ -5,26 +5,25 @@

6module Data.Schematic.Schema where

8−import Control.Applicative

8+import Control.Applicative ()

9−import Control.Monad

9+import Control.Monad

10−import Data.Aeson as J

10+import Data.Aeson as J

11−import Data.Aeson.Types as J

11+import Data.Aeson.Types as J

12−import Data.HashMap.Strict as H

12+import Data.HashMap.Strict as H

13−import Data.Kind

13+import Data.Kind

14−import Data.Maybe

14+import Data.Maybe

15−import Data.Schematic.Instances ()

15+import Data.Schematic.Instances ()

16−

17−import Data.Scientific

16+import Data.Scientific

18−import Data.Singletons.Prelude.List hiding (All)

17+import Data.Singletons.Prelude.List hiding (All)

19−import Data.Singletons.TH

18+import Data.Singletons.TH

20−import Data.Singletons.TypeLits

19+import Data.Singletons.TypeLits

21−import Data.Text as T

20+import Data.Text as T

22−import Data.Vector as V

21+import Data.Vector as V

23−import Data.Vinyl hiding (Dict)

22+import Data.Vinyl hiding (Dict)

24−import Data.Vinyl.TypeLevel hiding (Nat)

23+import qualified Data.Vinyl.TypeLevel as V

25−import GHC.Generics (Generic)

24+import GHC.Generics (Generic)

26−import Prelude as P

25+import Prelude as P

27−import Test.SmallCheck.Series

26+import Test.SmallCheck.Series

30type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

29type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

@@ -137,6 +136,10 @@ data FieldRepr :: (Symbol, Schema) -> Type where

137 => JsonRepr schema

136 => JsonRepr schema

138 -> FieldRepr '(name, schema)

137 -> FieldRepr '(name, schema)

139

138

139+-- | Forgetful Functor Ufr

140+toJsonRepr :: FieldRepr '(fn, sch) -> JsonRepr sch

141+toJsonRepr (FieldRepr x) = x

142+

140knownFieldName

143knownFieldName

141 :: forall proxy (fieldName :: Symbol) schema

144 :: forall proxy (fieldName :: Symbol) schema

142 . KnownSymbol fieldName

145 . KnownSymbol fieldName

@@ -182,7 +185,7 @@ instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"

182instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where

185instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where

183 show (ReprArray v) = "ReprArray " P.++ show v

186 show (ReprArray v) = "ReprArray " P.++ show v

184

187

185−instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

188+instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

186 show (ReprObject fs) = "ReprObject " P.++ show fs

189 show (ReprObject fs) = "ReprObject " P.++ show fs

187

190

188instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

191instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where