528c168 · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

Simplified singleton term search

528c168Denis Redozubov9 years ago

src/Data/Schematic.hs+8−8

compare with master

unifiedsplit

@@ -60,7 +60,7 @@ parseAndValidateJsonBySing sschema v = case parseEither parseJSON v of

61parseAndValidateTopVersionJson

62 :: forall proxy (v :: Versioned)

63− . (Known (Sing (TopVersion (AllVersions v))))

63+ . (SingI (TopVersion (AllVersions v)))

64 => proxy v

65 -> J.Value

66 -> ParseResult (JsonRepr (TopVersion (AllVersions v)))

@@ -70,7 +70,7 @@ parseAndValidateTopVersionJson _ v =

70 Right jsonRepr ->

71 let

72 validate =

73− validateJsonRepr (known :: Sing (TopVersion (AllVersions v))) [] jsonRepr

73+ validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr

74 res = runIdentity . runValidationTEither $ validate

75 in case res of

76 Left em -> ValidationError em

@@ -78,19 +78,19 @@ parseAndValidateTopVersionJson _ v =

79parseAndValidateVersionedJson

80 :: forall proxy rav av (v :: Versioned) rs tv

81− . ( Known (Sing (AllVersions v))

81+ . ( SingI (AllVersions v)

82 , Migratable (SchemaPairs (AllVersions v))

83− , (Known (Sing (TopVersion (AllVersions v))))

83+ , SingI (TopVersion (AllVersions v))

84− , (Known (Sing (SchemaPairs (AllVersions v)))))

84+ , SingI (SchemaPairs (AllVersions v)))

85 => proxy v

86 -> J.Value

87 -> ParseResult (JsonRepr (TopVersion (AllVersions v)))

88parseAndValidateVersionedJson _ v =

89 let

90 rss :: Sing (SchemaPairs (AllVersions v))

91− rss = known

91+ rss = sing

92 stv :: Sing (TopVersion (AllVersions v))

93− stv = known

93+ stv = sing

94 in parseAndValidateVersionedJsonByVersions stv rss v

96parseAndValidateVersionedJsonByVersions

@@ -108,7 +108,7 @@ parseAndValidateVersionedJsonByVersions stv srs value = case srs of

108

109decodeAndValidateJson

110 :: forall schema

111− . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema))

111+ . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

112 => BL.ByteString

113 -> ParseResult (JsonRepr schema)

114decodeAndValidateJson bs = case decode bs of

src/Data/Schematic/Migration.hs+14−14

@@ -20,6 +20,12 @@ data instance Sing (p :: Path) where

20 SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)

21 SPTraverse :: Sing 'PTraverse

23+instance KnownSymbol s => SingI ('PKey s) where

24+ sing = SPKey sing

25+

26+instance SingI 'PTraverse where

27+ sing = SPTraverse

28+

23-- Result type blueprint

29-- Result type blueprint

24data Builder

30data Builder

25 = BKey Schema Symbol Builder -- field schema

31 = BKey Schema Symbol Builder -- field schema

@@ -79,8 +85,8 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where

79type family Migratable (rs :: [(Revision, Schema)]) :: Constraint where

85type family Migratable (rs :: [(Revision, Schema)]) :: Constraint where

80 -- constraint duplication

86 -- constraint duplication

81 Migratable ('(r,s) ': '(r', s') ': tl) =

87 Migratable ('(r,s) ': '(r', s') ': tl) =

82− (Known (Sing s), MigrateSchema s s', TopLevel s, Migratable ('(r',s') ': tl))

88+ (SingI s, MigrateSchema s s', TopLevel s, Migratable ('(r',s') ': tl))

83− Migratable ('(r,s) ': '[]) = (TopLevel s, Known (Sing s))

89+ Migratable ('(r,s) ': '[]) = (TopLevel s, SingI s)

84 -- Migratable '[] = ('True ~ 'False)

90 -- Migratable '[] = ('True ~ 'False)

86-- data NonEmpty a = a :| [a]

92-- data NonEmpty a = a :| [a]

@@ -94,7 +100,7 @@ data Revisions = Revisions

100

95data instance Sing (rs :: Revisions) where

101data instance Sing (rs :: Revisions) where

96 SRevisions

102 SRevisions

97− :: (Known (Sing schema), Known (Sing rps), Known (Dict (ElemOf schema prs)))

103+ :: (SingI schema, SingI rps, Known (Dict (ElemOf schema prs)))

98 => Sing schema

104 => Sing schema

99 -> Sing rps

105 -> Sing rps

100 -> Sing ('Revisions schema rps)

106 -> Sing ('Revisions schema rps)

@@ -135,26 +141,20 @@ data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

135

141

136data instance Sing (a :: Action) where

142data instance Sing (a :: Action) where

137 SAddKey

143 SAddKey

138− :: (Known (Sing n), Known (Sing s))

144+ :: (SingI n, SingI s)

139 => Sing n

145 => Sing n

140 -> Sing s

146 -> Sing s

141 -> Sing ('AddKey n s)

147 -> Sing ('AddKey n s)

142− SUpdate :: Known (Sing s) => Sing s -> Sing ('Update s)

148+ SUpdate :: (SingI s) => Sing s -> Sing ('Update s)

143 SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)

149 SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)

144

150

145−instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where

146− known = SAddKey known known

147−instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known

148−instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('DeleteKey s)) where

149− known = SDeleteKey known

150−

151-- | User-supplied atomic difference between schemas.

152-- Migrations can consists of many differences.

153data Diff = Diff [Path] Action

154

155data instance Sing (diff :: Diff) where

156 SDiff

157− :: (Known (Sing jp), Known (Sing a))

157+ :: (SingI jp, SingI a)

158 => Sing (jp :: [Path])

159 -> Sing (a :: Action)

160 -> Sing ('Diff jp a)

@@ -166,7 +166,7 @@ data Migration = Migration Revision [Diff]

166

167data instance Sing (m :: Migration) where

168 SMigration

169− :: (KnownSymbol r, Known (Sing ds))

169+ :: (KnownSymbol r, SingI ds)

170 => Sing r

171 -> Sing ds

172 -> Sing ('Migration r ds)

@@ -175,7 +175,7 @@ data Versioned = Versioned Schema [Migration]

175

176data instance Sing (v :: Versioned) where

177 SVersioned

178− :: (Known (Sing s), Known (Sing ms))

178+ :: (SingI s, SingI ms)

179 => Sing (s :: Schema) -- base version

180 -> Sing (ms :: [Migration]) -- a bunch of migrations

181 -> Sing ('Versioned s ms)

src/Data/Schematic/Schema.hs+36−36

@@ -13,7 +13,7 @@ import Data.HashMap.Strict as H

13import Data.Kind

14import Data.Maybe

15import Data.Schematic.Instances ()

16−import Data.Schematic.Utils

16+

17import Data.Scientific

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

19import Data.Singletons.TH

@@ -49,14 +49,14 @@ data instance Sing (tc :: TextConstraint) where

49 STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)

50 STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)

51 STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)

52− STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s)

52+ STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)

53− STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)

53+ STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)

55−instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known

55+instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing

56−instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known

56+instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing

57−instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known

57+instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing

58−instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known

58+instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing

59−instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known

59+instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing

61instance Eq (Sing ('TEq n)) where _ == _ = True

62instance Eq (Sing ('TLe n)) where _ == _ = True

@@ -75,9 +75,9 @@ data instance Sing (nc :: NumberConstraint) where

75 SNGt :: KnownNat n => Sing n -> Sing ('NGt n)

76 SNLe :: KnownNat n => Sing n -> Sing ('NLe n)

78−instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known

78+instance KnownNat n => SingI ('NEq n) where sing = SNEq sing

79−instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known

79+instance KnownNat n => SingI ('NGt n) where sing = SNGt sing

80−instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known

80+instance KnownNat n => SingI ('NLe n) where sing = SNLe sing

82instance Eq (Sing ('NEq n)) where _ == _ = True

83instance Eq (Sing ('NLe n)) where _ == _ = True

@@ -90,7 +90,7 @@ data ArrayConstraint

90data instance Sing (ac :: ArrayConstraint) where

91 SAEq :: KnownNat n => Sing n -> Sing ('AEq n)

93−instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known

93+instance KnownNat n => SingI ('AEq n) where sing = SAEq sing

95instance Eq (Sing ('AEq n)) where _ == _ = True

@@ -104,25 +104,25 @@ data Schema

104 deriving (Generic)

105

106data instance Sing (schema :: Schema) where

107− SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)

107+ SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)

108− SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)

108+ SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)

109− SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

109+ SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

110− SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)

110+ SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)

111− SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)

111+ SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)

112 SSchemaNull :: Sing 'SchemaNull

113

114−instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where

114+instance SingI sl => SingI ('SchemaText sl) where

115− known = SSchemaText known

115+ sing = SSchemaText sing

116−instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where

116+instance SingI sl => SingI ('SchemaNumber sl) where

117− known = SSchemaNumber known

117+ sing = SSchemaNumber sing

118−instance Known (Sing 'SchemaNull) where

118+instance SingI 'SchemaNull where

119− known = SSchemaNull

119+ sing = SSchemaNull

120−instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where

120+instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where

121− known = SSchemaArray known known

121+ sing = SSchemaArray sing sing

122−instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where

122+instance SingI stl => SingI ('SchemaObject stl) where

123− known = SSchemaObject known

123+ sing = SSchemaObject sing

124−instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where

124+instance SingI s => SingI ('SchemaOptional s) where

125− known = SSchemaOptional known

125+ sing = SSchemaOptional sing

126

127instance Eq (Sing ('SchemaText cs)) where _ == _ = True

128instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True

@@ -133,7 +133,7 @@ instance Eq (Sing ('SchemaOptional s)) where _ == _ = True

133

134data FieldRepr :: (Symbol, Schema) -> Type where

135 FieldRepr

136− :: (Known (Sing schema), KnownSymbol name)

136+ :: (SingI schema, KnownSymbol name)

137 => JsonRepr schema

138 -> FieldRepr '(name, schema)

139

@@ -146,10 +146,10 @@ knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName)

146

147knownFieldSchema

148 :: forall proxy fieldName schema

149− . Known (Sing schema)

149+ . SingI schema

150 => proxy '(fieldName, schema)

151 -> Sing schema

152−knownFieldSchema _ = known

152+knownFieldSchema _ = sing

153

154deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))

155

@@ -158,7 +158,7 @@ instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where

158

159instance

160 ( KnownSymbol name

161− , Known (Sing schema)

161+ , SingI schema

162 , Serial m (JsonRepr schema) )

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

164 series = FieldRepr <$> series

@@ -230,14 +230,14 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where

230 ReprOptional a == ReprOptional b = a == b

231

232fromOptional

233− :: (Known (Sing s))

233+ :: SingI s

234 => Sing ('SchemaOptional s)

235 -> J.Value

236 -> Parser (Maybe (JsonRepr s))

237fromOptional _ = parseJSON

238

239−instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where

239+instance SingI schema => J.FromJSON (JsonRepr schema) where

240− parseJSON value = case known :: Sing schema of

240+ parseJSON value = case sing :: Sing schema of

241 SSchemaText _ -> withText "String" (pure . ReprText) value

242 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value

243 SSchemaNull -> case value of