0c59636 · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

try out superrecord

0c59636Denis Redozubov9 years ago

schematic.cabal+2−2

compare with master

unifiedsplit

@@ -66,12 +66,12 @@ library

66 , singletons

67 , smallcheck

68 , smallcheck-series

69+ , superrecord

69 , tagged

70 , tagged

70 , text

71 , text

71 , unordered-containers

72 , unordered-containers

72 , validationt >= 0.1.0.1

73 , validationt >= 0.1.0.1

73 , vector

74 , vector

74− , vinyl

75 hs-source-dirs: src

76 default-language: Haskell2010

@@ -120,10 +120,10 @@ test-suite spec

120 , smallcheck

121 , smallcheck-series

122 , singletons

123+ , superrecord

123 , tagged

124 , tagged

124 , text

125 , text

125 , unordered-containers

126 , unordered-containers

126 , validationt >= 0.1.0.1

127 , validationt >= 0.1.0.1

127− , vinyl

128 other-modules: SchemaSpec

129 , LensSpec

src/Data/Schematic/Instances.hs+5−6

@@ -5,16 +5,15 @@ module Data.Schematic.Instances where

6import Data.Scientific

7import Data.Vector as V

8−import Data.Vinyl

9import Test.SmallCheck.Series

8import Test.SmallCheck.Series

12−instance Monad m => Serial m (Rec f '[]) where

11+-- instance Monad m => Serial m (Rec f '[]) where

13− series = cons0 RNil

12+-- series = cons0 RNil

15−instance (Serial m (f a), Serial m (Rec f as), Monad m)

14+-- instance (Serial m (f a), Serial m (Rec f as), Monad m)

16− => Serial m (Rec f (a ': as)) where

15+-- => Serial m (Rec f (a ': as)) where

17− series = cons2 (:&)

16+-- series = cons2 (:&)

19instance Serial m a => Serial m (V.Vector a) where

18instance Serial m a => Serial m (V.Vector a) where

20 series = V.fromList <$> series

19 series = V.fromList <$> series

src/Data/Schematic/Schema.hs+37−26

@@ -5,25 +5,24 @@

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−import Data.Scientific

16+import Data.Scientific

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

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

18−import Data.Singletons.TH

18+import Data.Singletons.TH

19−import Data.Singletons.TypeLits

19+import Data.Singletons.TypeLits

20−import Data.Text as T

20+import Data.Text as T

21−import Data.Vector as V

21+import Data.Vector as V

22−import Data.Vinyl hiding (Dict)

23−import qualified Data.Vinyl.TypeLevel as V

24−import GHC.Generics (Generic)

22+import GHC.Generics (Generic)

25−import Prelude as P

23+import Prelude as P

24+import SuperRecord

26−import Test.SmallCheck.Series

25+import Test.SmallCheck.Series

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

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

@@ -166,12 +165,18 @@ instance

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

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

167 series = FieldRepr <$> series

166 series = FieldRepr <$> series

168

167

168+type family Fields (ts :: [u]) :: [] where

169+ Fields '[] = '[]

170+ Fields (t ': ts) = (FieldRepr t ': Fields ts)

171+

172+type JObject ts = Rec (Fields ts)

173+

169data JsonRepr :: Schema -> Type where

174data JsonRepr :: Schema -> Type where

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

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

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

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

172 ReprNull :: JsonRepr 'SchemaNull

177 ReprNull :: JsonRepr 'SchemaNull

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

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

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

179+ ReprObject :: JObject fs -> JsonRepr ('SchemaObject fs)

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

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

176

181

177instance Show (JsonRepr ('SchemaText cs)) where

182instance Show (JsonRepr ('SchemaText cs)) where

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

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

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

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

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

187

192

193+-- There's a PR in the superrecord library, remove it if gets merged.

194+type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where

195+ RecAll c '[] = ()

196+ RecAll c (r ': rs) = (c r, RecAll c rs)

197+

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

198+instance RecAll Show fs => Show (JsonRepr ('SchemaObject fs)) where

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

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

190

200

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

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

@@ -210,11 +220,11 @@ instance (Serial m (JsonRepr s))

210 => Serial m (JsonRepr ('SchemaOptional s)) where

220 => Serial m (JsonRepr ('SchemaOptional s)) where

211 series = cons1 ReprOptional

221 series = cons1 ReprOptional

212

222

213−instance (Monad m, Serial m (Rec FieldRepr fs))

223+instance (Monad m, Serial m (JObject fs))

214 => Serial m (JsonRepr ('SchemaObject fs)) where

224 => Serial m (JsonRepr ('SchemaObject fs)) where

215 series = cons1 ReprObject

225 series = cons1 ReprObject

216

226

217−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where

227+instance Eq (JObject fs) => Eq (JsonRepr ('SchemaObject fs)) where

218 ReprObject a == ReprObject b = a == b

228 ReprObject a == ReprObject b = a == b

219

229

220instance Eq (JsonRepr ('SchemaText cs)) where

230instance Eq (JsonRepr ('SchemaText cs)) where

@@ -251,7 +261,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

251 $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

261 $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

252 SSchemaObject fs -> do

262 SSchemaObject fs -> do

253 let

263 let

254− demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)

264+ demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (JObject s)

255 demoteFields SNil _ = pure RNil

265 demoteFields SNil _ = pure RNil

256 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

266 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

257 let fieldName = T.pack $ symbolVal (Proxy @fn)

267 let fieldName = T.pack $ symbolVal (Proxy @fn)

@@ -287,11 +297,12 @@ instance J.ToJSON (JsonRepr a) where

287 toJSON (ReprArray v) = J.Array $ toJSON <$> v

297 toJSON (ReprArray v) = J.Array $ toJSON <$> v

288 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

298 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

289 where

299 where

300+ extract

290− extract :: forall name s . (KnownSymbol name)

301+ :: forall name s . (KnownSymbol name)

291 => FieldRepr '(name, s)

302 => FieldRepr '(name, s)

292 -> (Text, Value)

303 -> (Text, Value)

293 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)

304 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)

294− fold :: Rec FieldRepr fs -> [(Text, J.Value)]

305+ fold :: JObject fs -> [(Text, J.Value)]

295 fold = \case

306 fold = \case

296 RNil -> []

307 RNil -> []

297 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

308 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl