git.iko.soy/typeable/schematic
on master help sign in
Add convenience isomorphisms
b24193dDenis Redozubov
schematic.cabal+1
compare with master
unifiedsplit
@@ -63,6 +63,7 @@ library
63 , containers
63 , containers
64 , hjsonschema
64 , hjsonschema
65 , mtl
65 , mtl
66+ , profunctors
66 , regex-tdfa
67 , regex-tdfa
67 , regex-tdfa-text
68 , regex-tdfa-text
68 , scientific
69 , scientific
src/Data/Schematic/Lens.hs+59−2
@@ -8,14 +8,26 @@ module Data.Schematic.Lens
8 , FElem(..)
8 , FElem(..)
9 , FImage
9 , FImage
10 , FSubset(..)
10 , FSubset(..)
11+ , obj
12+ , textRepr
13+ , numberRepr
14+ , boolRepr
15+ , arrayRepr
16+ , objectRepr
17+ , optionalRepr
11 ) where
18 ) where
12
19
20+import Data.Profunctor
13import Data.Proxy
21import Data.Proxy
14import Data.Schematic.Schema
22import Data.Schematic.Schema
23+import Data.Scientific
24+import Data.Singletons
25+import Data.Text
26+import Data.Vector as V
15import Data.Vinyl
27import Data.Vinyl
16import Data.Vinyl.Functor
28import Data.Vinyl.Functor
17import Data.Vinyl.TypeLevel (Nat(..))
29import Data.Vinyl.TypeLevel (Nat(..))
18−import GHC.TypeLits (Symbol)
30+import GHC.TypeLits (Symbol, KnownSymbol)
19
31
20
32
21-- | A partial relation that gives the index of a value in a list.
33-- | A partial relation that gives the index of a value in a list.
@@ -70,7 +82,7 @@ instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) w
70 fput y = getIdentity . flens Proxy (\_ -> Identity y)
82 fput y = getIdentity . flens Proxy (\_ -> Identity y)
71 {-# INLINE fput #-}
83 {-# INLINE fput #-}
72
84
73−-- This is an internal convenience stolen from the @lens@ library.
85+-- This is an internal convenience helpers stolen from the @lens@ library.
74lens
86lens
75 :: Functor f
87 :: Functor f
76 => (t -> s)
88 => (t -> s)
@@ -81,6 +93,17 @@ lens
81lens sa sbt afb s = fmap (sbt s) $ afb (sa s)
93lens sa sbt afb s = fmap (sbt s) $ afb (sa s)
82{-# INLINE lens #-}
94{-# INLINE lens #-}
83
95
96+type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
97+
98+type Iso' s a = Iso s s a a
99+
100+iso
101+ :: (s -> a)
102+ -> (b -> t)
103+ -> Iso s t a b
104+iso sa bt = dimap sa (fmap bt)
105+{-# INLINE iso #-}
106+
84-- | A partial relation that gives the indices of a sublist in a larger list.
107-- | A partial relation that gives the indices of a sublist in a larger list.
85type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where
108type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where
86 FImage '[] ss = '[]
109 FImage '[] ss = '[]
@@ -125,3 +148,37 @@ instance
125 where
148 where
126 set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss
149 set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss
127 set ss (r :& rs) = fput r $ freplace rs ss
150 set ss (r :& rs) = fput r $ freplace rs ss
151+
152+-- A bunch of @Iso@morphisms
153+textRepr
154+ :: (KnownSymbol fn, SingI fn, SingI cs)
155+ => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text
156+textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)
157+
158+numberRepr
159+ :: (KnownSymbol fn, SingI fn, SingI cs)
160+ => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific
161+numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)
162+
163+boolRepr
164+ :: (KnownSymbol fn, SingI fn, SingI cs)
165+ => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool
166+boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)
167+
168+arrayRepr
169+ :: (KnownSymbol fn, SingI fn, SingI cs, SingI schema)
170+ => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))
171+arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)
172+
173+objectRepr
174+ :: (KnownSymbol fn, SingI fn, SingI fields)
175+ => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)
176+objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)
177+
178+optionalRepr
179+ :: (KnownSymbol fn, SingI fn, SingI schema)
180+ => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))
181+optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)
182+
183+obj :: (SingI fields) => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)
184+obj = iso (\(ReprObject r) -> r) ReprObject