528c168 · schematic · git.iko.soy

git.iko.soy/schematic

Simplified singleton term search

commit528c1687fee8ec9692f11916419444d9be75efe4 authorDenis Redozubov <denis.redozubov@gmail.com> dateFri 9 Jun 2017, 15:52 (9 years ago) parentdebbecc

3 files changed+58−58

compare with master

unifiedsplit

src/Data/Schematic.hs+8−8 src/Data/Schematic/Migration.hs+14−14 src/Data/Schematic/Schema.hs+36−36

src/Data/Schematic.hs+8−8

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

6060

6161parseAndValidateTopVersionJson

6262 :: forall proxy (v :: Versioned)

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

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

6464 => proxy v

6565 -> J.Value

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

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

7070 Right jsonRepr ->

7171 let

7272 validate =

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

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

7474 res = runIdentity . runValidationTEither $ validate

7575 in case res of

7676 Left em -> ValidationError em

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

7878

7979parseAndValidateVersionedJson

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

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

81+ . ( SingI (AllVersions v)

8282 , Migratable (SchemaPairs (AllVersions v))

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

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

83+ , SingI (TopVersion (AllVersions v))

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

8585 => proxy v

8686 -> J.Value

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

8888parseAndValidateVersionedJson _ v =

8989 let

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

91− rss = known

91+ rss = sing

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

93− stv = known

93+ stv = sing

9494 in parseAndValidateVersionedJsonByVersions stv rss v

9595

9696parseAndValidateVersionedJsonByVersions

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

108108

109109decodeAndValidateJson

110110 :: forall schema

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

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

112112 => BL.ByteString

113113 -> ParseResult (JsonRepr schema)

114114decodeAndValidateJson bs = case decode bs of

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

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

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

2121 SPTraverse :: Sing 'PTraverse

2222

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

24+ sing = SPKey sing

25+

26+instance SingI 'PTraverse where

27+ sing = SPTraverse

28+

2329-- Result type blueprint

2430data Builder

2531 = BKey Schema Symbol Builder -- field schema

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

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

8086 -- constraint duplication

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

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

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

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

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

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

8591

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

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

94100

95101data instance Sing (rs :: Revisions) where

96102 SRevisions

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

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

98104 => Sing schema

99105 -> Sing rps

100106 -> Sing ('Revisions schema rps)

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

135141

136142data instance Sing (a :: Action) where

137143 SAddKey

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

144+ :: (SingI n, SingI s)

139145 => Sing n

140146 -> Sing s

141147 -> Sing ('AddKey n s)

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

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

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

144150

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−

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

152152-- Migrations can consists of many differences.

153153data Diff = Diff [Path] Action

154154

155155data instance Sing (diff :: Diff) where

156156 SDiff

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

157+ :: (SingI jp, SingI a)

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

159159 -> Sing (a :: Action)

160160 -> Sing ('Diff jp a)

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

166166

167167data instance Sing (m :: Migration) where

168168 SMigration

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

169+ :: (KnownSymbol r, SingI ds)

170170 => Sing r

171171 -> Sing ds

172172 -> Sing ('Migration r ds)

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

175175

176176data instance Sing (v :: Versioned) where

177177 SVersioned

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

178+ :: (SingI s, SingI ms)

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

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

181181 -> Sing ('Versioned s ms)

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

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

1313import Data.Kind

1414import Data.Maybe

1515import Data.Schematic.Instances ()

16−import Data.Schematic.Utils

16+

1717import Data.Scientific

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

1919import Data.Singletons.TH

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

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

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

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

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

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

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

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

5454

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

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

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

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

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

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

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

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

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

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

6060

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

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

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

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

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

7777

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

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

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

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

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

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

8181

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

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

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

9090data instance Sing (ac :: ArrayConstraint) where

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

9292

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

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

9494

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

9696

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

104104 deriving (Generic)

105105

106106data instance Sing (schema :: Schema) where

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

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

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

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

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

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

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

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

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

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

112112 SSchemaNull :: Sing 'SchemaNull

113113

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

115− known = SSchemaText known

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

117− known = SSchemaNumber known

118−instance Known (Sing 'SchemaNull) where

119− known = SSchemaNull

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

121− known = SSchemaArray known known

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

123− known = SSchemaObject known

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

125− known = SSchemaOptional known

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

115+ sing = SSchemaText sing

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

117+ sing = SSchemaNumber sing

118+instance SingI 'SchemaNull where

119+ sing = SSchemaNull

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

121+ sing = SSchemaArray sing sing

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

123+ sing = SSchemaObject sing

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

125+ sing = SSchemaOptional sing

126126

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

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

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

133133

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

135135 FieldRepr

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

136+ :: (SingI schema, KnownSymbol name)

137137 => JsonRepr schema

138138 -> FieldRepr '(name, schema)

139139

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

146146

147147knownFieldSchema

148148 :: forall proxy fieldName schema

149− . Known (Sing schema)

149+ . SingI schema

150150 => proxy '(fieldName, schema)

151151 -> Sing schema

152−knownFieldSchema _ = known

152+knownFieldSchema _ = sing

153153

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

155155

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

158158

159159instance

160160 ( KnownSymbol name

161− , Known (Sing schema)

161+ , SingI schema

162162 , Serial m (JsonRepr schema) )

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

164164 series = FieldRepr <$> series

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

230230 ReprOptional a == ReprOptional b = a == b

231231

232232fromOptional

233− :: (Known (Sing s))

233+ :: SingI s

234234 => Sing ('SchemaOptional s)

235235 -> J.Value

236236 -> Parser (Maybe (JsonRepr s))

237237fromOptional _ = parseJSON

238238

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

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

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

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

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

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

243243 SSchemaNull -> case value of