5be2bf6 · typeable/schematic

git.iko.soy/typeable/schematic

on master help sign in

Constructor DSL

5be2bf6Denis Redozubov9 years ago

src/Data/Schematic.hs+87−14

compare with master

unifiedsplit

@@ -19,22 +19,33 @@ module Data.Schematic

19 , isDecodingError

20 , isValidationError

21 , ParseResult(..)

22+ , withRepr

23+ , field

24+ , (<:&>)

22 ) where

25 ) where

27+import Control.Applicative

24−import Control.Monad.Validation

28+import Control.Monad.Validation

25−import Data.Aeson as J

29+import Data.Aeson as J

26−import Data.Aeson.Types as J

30+import Data.Aeson.Types as J

27−import Data.ByteString.Lazy as BL

31+import Data.ByteString.Lazy as BL

28−import Data.Functor.Identity

32+import Data.Functor.Identity

29−import Data.Schematic.JsonSchema

33+import Data.Kind

30−import Data.Schematic.Helpers

34+import Data.Schematic.Helpers

35+import Data.Schematic.JsonSchema

31−import Data.Schematic.Lens

36+import Data.Schematic.Lens

32−import Data.Schematic.Migration

37+import Data.Schematic.Migration

33−import Data.Schematic.Schema

38+import Data.Schematic.Schema

34−import Data.Schematic.Utils

39+import Data.Schematic.Utils

35−import Data.Schematic.Validation

40+import Data.Schematic.Validation

41+import Data.Scientific

36−import Data.Singletons.Prelude

42+import Data.Singletons.Prelude

43+import Data.Singletons.TypeLits

44+import Data.Tagged

37−import Data.Text as T

45+import Data.Text as T

46+import Data.Union

47+import qualified Data.Vector as V

48+import Data.Vinyl

40parseAndValidateJson

51parseAndValidateJson

@@ -125,3 +136,65 @@ decodeAndValidateVersionedWithPureMList

125 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

136 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

126decodeAndValidateVersionedWithPureMList a b c =

137decodeAndValidateVersionedWithPureMList a b c =

127 runIdentity $ decodeAndValidateVersionedWithMList a b c

138 runIdentity $ decodeAndValidateVersionedWithMList a b c

139+

140+-- convenience helpers

141+

142+type Constructor a

143+ = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

144+ => Tagged (FieldsOf a) (Rec FieldRepr b)

145+ -> JsonRepr ('SchemaObject (FieldsOf a))

146+

147+withRepr :: Constructor a

148+withRepr = ReprObject . unTagged . fmap fcast

149+

150+(<:&>)

151+ :: Applicative m

152+ => m (FieldRepr fns)

153+ -> m (Rec FieldRepr b)

154+ -> m (Rec FieldRepr (fns ': b))

155+(<:&>) = liftA2 (:&)

156+

157+infixr 7 <:&>

158+

159+class Representable s where

160+ type Repr s :: Type

161+ construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)

162+

163+instance SingI so => Representable ('SchemaObject so) where

164+ type Repr ('SchemaObject so) = Rec FieldRepr so

165+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o

166+

167+instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where

168+ type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)

169+ construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a

170+

171+instance SingI cs => Representable ('SchemaText cs) where

172+ type Repr ('SchemaText cs) = Text

173+ construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t

174+

175+instance SingI cs => Representable ('SchemaNumber cs) where

176+ type Repr ('SchemaNumber cs) = Scientific

177+ construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n

178+

179+instance Representable 'SchemaBoolean where

180+ type Repr 'SchemaBoolean = Bool

181+ construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b

182+

183+instance SingI so => Representable ('SchemaOptional so) where

184+ type Repr ('SchemaOptional so) = Maybe (JsonRepr so)

185+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o

186+

187+instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where

188+ type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)

189+ construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u

190+

191+type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where

192+ FieldsOf ('SchemaObject fs) = fs

193+

194+type FieldConstructor fn =

195+ forall fs. (Representable (ByField fn fs (FIndex fn fs)))

196+ => Repr (ByField fn fs (FIndex fn fs))

197+ -> Tagged fs (FieldRepr '(fn, (ByField fn fs (FIndex fn fs))))

198+

199+field :: forall fn. KnownSymbol fn => FieldConstructor fn

200+field = Tagged . construct (sing :: Sing fn) Proxy

src/Data/Schematic/Lens.hs+1−2

@@ -98,8 +98,7 @@ type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f

98type Iso' s a = Iso s s a a

100iso

101− :: (s -> a)

101+ :: (s -> a) -> (b -> t)

102− -> (b -> t)

103 -> Iso s t a b

102 -> Iso s t a b

104iso sa bt = dimap sa (fmap bt)

103iso sa bt = dimap sa (fmap bt)

105{-# INLINE iso #-}

104{-# INLINE iso #-}

src/Data/Schematic/Schema.hs+9−2

@@ -319,6 +319,10 @@ instance

319 => Serial m (FieldRepr '(name, schema)) where

320 series = FieldRepr <$> series

321

322+type family USubsets (u :: [k]) :: Constraint where

323+ USubsets '[] = ()

324+ USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)

325+

322data JsonRepr :: Schema -> Type where

326data JsonRepr :: Schema -> Type where

323 ReprText :: Text -> JsonRepr ('SchemaText cs)

327 ReprText :: Text -> JsonRepr ('SchemaText cs)

324 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

328 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

@@ -327,9 +331,12 @@ data JsonRepr :: Schema -> Type where

327 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

331 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

328 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

332 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

329 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

333 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

334+ ReprUnion

335+ -- :: USubsets (h ': tl)

336+ :: Union JsonRepr (h ': tl)

330− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))

337+ -> JsonRepr ('SchemaUnion (h ': tl))

331

338

332−-- | Move to the different package

339+-- | Move to the union package

333type family UnionAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where

340type family UnionAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where

334 UnionAll f '[] c = ()

341 UnionAll f '[] c = ()

335 UnionAll f (r ': rs) c = (c (f r), UnionAll f rs c)

342 UnionAll f (r ': rs) c = (c (f r), UnionAll f rs c)

src/Data/Schematic/Validation.hs+38−15

@@ -16,6 +16,7 @@ import Data.Traversable

16import Data.Union

17import Data.Vector as V

18import Data.Vinyl

19+import Data.Vinyl.TypeLevel

19import Prelude as P

20import Prelude as P

20import Text.Regex.TDFA

21import Text.Regex.TDFA

@@ -206,21 +207,43 @@ validateJsonRepr sschema dpath jr = case jr of

206 let newPath = dpath <> [DKey (knownFieldName f)]

207 let newPath = dpath <> [DKey (knownFieldName f)]

207 validateJsonRepr (knownFieldSchema f) newPath d

208 validateJsonRepr (knownFieldSchema f) newPath d

208 go ftl

209 go ftl

209− ReprUnion u -> pure () -- case sschema of

210+ ReprUnion u -> pure ()

211+ -- case sschema of

210− -- SSchemaUnion ss -> case ss of

212+ -- SSchemaUnion ss -> case ss of

211− -- SNil -> do

213+ -- SCons s stl -> case umatch' s u of

214+ -- Nothing -> case urestrict u of

215+ -- Nothing ->

216+ -- fail "impossible to produce subUnion, please report this as a bug"

217+ -- Just x -> do

218+ -- let

212− -- let JSONPath path = demotedPathToText dpath

219+ -- JSONPath path = demotedPathToText dpath

220+ -- case stl of

213− -- void $ vWarning $ mmSingleton path

221+ -- SNil -> void $ vWarning $ mmSingleton path

214− -- $ pure "union handling error, please report this as bug"

222+ -- $ pure "union handling error, please report this as bug"

215− -- SCons s stl -> case umatch' s u of

223+ -- SCons s' stl' ->

216− -- Nothing -> case urestrict u of

224+ -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath

217− -- Nothing -> fail "impossible to urestrict union, please report this as a bug"

225+ -- $ toUnion (SCons s' stl') x

218− -- Just x -> do

226+ -- Just x -> validateJsonRepr s dpath x

219− -- let

227+

228+-- subUnion

229+-- :: Sing (s ': stl)

230+-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))

231+-- => Union f (s ': stl)

232+-- -> Maybe (Union f stl) )

233+-- subUnion (SCons s stl) = urestrict

234+

235+-- withUSubset

236+-- :: Sing (s ': stl)

237+-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))

238+-- -> Maybe (Union f stl)

239+-- withUSubset (SCons s stl) r = r

240+

241+toUnion

242+ :: USubset s' (s ': ss) (RImage s' (s ': ss))

243+ => Sing (s ': ss)

244+ -> Union JsonRepr s'

220− -- toUnion :: Sing ss -> Union JsonRepr ss -> JsonRepr ('SchemaUnion ss)

245+ -> JsonRepr ('SchemaUnion (s ': ss))

221− -- toUnion _ = ReprUnion

246+toUnion _ = ReprUnion . urelax

222− -- validateJsonRepr (SSchemaUnion stl) dpath $ toUnion stl x

223− -- Just x -> validateJsonRepr s dpath x

224

247

225umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

248umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

226umatch' _ u = umatch u

249umatch' _ u = umatch u

test/SchemaSpec.hs+8−4

@@ -10,11 +10,15 @@ import Data.Schematic

10import Data.Vinyl

11import Test.Hspec

13+type SchemaExample = 'SchemaObject

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

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

14−type SchemaExample

17+example :: JsonRepr SchemaExample

15− = 'SchemaObject

18+example = withRepr @SchemaExample $

16− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

19+ field @"bar" (Just $ ReprText "bar")

17− , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

20+ <:&> field @"foo" [ReprNumber 12]

21+ <:&> pure RNil

19type TestMigration =

23type TestMigration =

20 'Migration "test_revision"

24 'Migration "test_revision"