schematic 0.3.1.0 → 0.3.2.0
raw patch · 4 files changed
+84/−18 lines, 4 filesdep +profunctors
Dependencies added: profunctors
Files
- ChangeLog.md +4/−0
- schematic.cabal +2/−1
- src/Data/Schematic/Lens.hs +75/−14
- test/LensSpec.hs +3/−3
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for schematic +## 0.3.2.0 -- 2017-10-02++Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.+ ## 0.3.1.0 -- 2017-09-28 Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens
schematic.cabal view
@@ -1,5 +1,5 @@ name: schematic-version: 0.3.1.0+version: 0.3.2.0 synopsis: JSON-biased spec and validation tool license: BSD3 license-file: LICENSE@@ -63,6 +63,7 @@ , containers , hjsonschema , mtl+ , profunctors , regex-tdfa , regex-tdfa-text , scientific
src/Data/Schematic/Lens.hs view
@@ -3,27 +3,44 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE InstanceSigs #-} -module Data.Schematic.Lens where+module Data.Schematic.Lens+ ( FIndex+ , FElem(..)+ , FImage+ , FSubset(..)+ , obj+ , textRepr+ , numberRepr+ , boolRepr+ , arrayRepr+ , objectRepr+ , optionalRepr+ ) where +import Data.Profunctor import Data.Proxy import Data.Schematic.Schema+import Data.Scientific+import Data.Singletons+import Data.Text+import Data.Vector as V import Data.Vinyl import Data.Vinyl.Functor import Data.Vinyl.TypeLevel (Nat(..))-import GHC.TypeLits (Symbol)+import GHC.TypeLits (Symbol, KnownSymbol) -- | A partial relation that gives the index of a value in a list. type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where- FIndex r ( '(fn, s) ': rs) = 'Z- FIndex r ( s ': rs) = 'S (FIndex r rs)+ FIndex r ( '(r, s) ': rs) = 'Z+ FIndex r ( s ': rs) = 'S (FIndex r rs) class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where- type ByRevision fn rs i :: Schema+ type ByField fn rs i :: Schema flens :: Functor g => proxy fn- -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))+ -> (FieldRepr '(fn, (ByField fn rs i)) -> g (FieldRepr '(fn, (ByField fn rs i)))) -> Rec FieldRepr rs -> g (Rec FieldRepr rs) @@ -31,18 +48,18 @@ fget :: proxy fn -> Rec FieldRepr rs- -> FieldRepr '(fn, (ByRevision fn rs i))+ -> FieldRepr '(fn, (ByField fn rs i)) -- | For Vinyl users who are not using the @lens@ package, we also provide a -- setter. In general, it will be unambiguous what field is being written to, -- and so we do not take a proxy argument here. fput- :: FieldRepr '(fn, ByRevision fn rs i)+ :: FieldRepr '(fn, ByField fn rs i) -> Rec FieldRepr rs -> Rec FieldRepr rs instance FElem fn ('(fn, r) ': rs) 'Z where- type ByRevision fn ('(fn, r) ': rs) 'Z = r+ type ByField fn ('(fn, r) ': rs) 'Z = r flens _ f (x :& xs) = fmap (:& xs) (f x) {-# INLINE flens #-}@@ -54,7 +71,7 @@ {-# INLINE fput #-} instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where- type ByRevision r (s ': rs) ('S i) = ByRevision r rs i+ type ByField r (s ': rs) ('S i) = ByField r rs i flens p f (x :& xs) = fmap (x :&) (flens p f xs) {-# INLINE flens #-}@@ -65,7 +82,7 @@ fput y = getIdentity . flens Proxy (\_ -> Identity y) {-# INLINE fput #-} --- This is an internal convenience stolen from the @lens@ library.+-- This is an internal convenience helpers stolen from the @lens@ library. lens :: Functor f => (t -> s)@@ -76,6 +93,17 @@ lens sa sbt afb s = fmap (sbt s) $ afb (sa s) {-# INLINE lens #-} +type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++type Iso' s a = Iso s s a a++iso+ :: (s -> a)+ -> (b -> t)+ -> Iso s t a b+iso sa bt = dimap sa (fmap bt)+{-# INLINE iso #-}+ -- | A partial relation that gives the indices of a sublist in a larger list. type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where FImage '[] ss = '[]@@ -113,11 +141,44 @@ fsubset = lens (const RNil) const instance- ( ByRevision fn ss i ~ s+ ( ByField fn ss i ~ s , FElem fn ss i- , FSubset rs ss is- ) => FSubset ( '(fn,s) ': rs) ss (i ': is) where+ , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set where set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss set ss (r :& rs) = fput r $ freplace rs ss++-- A bunch of @Iso@morphisms+textRepr+ :: (KnownSymbol fn, SingI fn, SingI cs)+ => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text+textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)++numberRepr+ :: (KnownSymbol fn, SingI fn, SingI cs)+ => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific+numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)++boolRepr+ :: (KnownSymbol fn, SingI fn, SingI cs)+ => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool+boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)++arrayRepr+ :: (KnownSymbol fn, SingI fn, SingI cs, SingI schema)+ => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))+arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)++objectRepr+ :: (KnownSymbol fn, SingI fn, SingI fields)+ => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)+objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)++optionalRepr+ :: (KnownSymbol fn, SingI fn, SingI schema)+ => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))+optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)++obj :: (SingI fields) => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)+obj = iso (\(ReprObject r) -> r) ReprObject
test/LensSpec.hs view
@@ -13,7 +13,7 @@ type ArrayField = '("foo", ArraySchema) type FieldsSchema =- '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]+ '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField] type SchemaExample = 'SchemaObject FieldsSchema @@ -24,8 +24,8 @@ arrayField = FieldRepr arrayData objectData :: Rec FieldRepr FieldsSchema-objectData = FieldRepr arrayData- :& FieldRepr (ReprOptional (Just (ReprText "foo")))+objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))+ :& FieldRepr arrayData :& RNil exampleData :: JsonRepr SchemaExample