b1b8d40 · schematic · git.iko.soy

git.iko.soy/schematic

move constructor DSL to a separate module & remove useless code

commitb1b8d40ad185985517ec6e04a06ddc6a7be26c22 authorDenis Redozubov <denis.redozubov@gmail.com> dateThu 12 Oct 2017, 16:00 (9 years ago) parent661b7e0

6 files changed+78−120

compare with master

unifiedsplit

schematic.cabal+2−1 src/Data/Schematic.hs+1−63 src/Data/Schematic/DSL.hs+71 src/Data/Schematic/Path.hs+4−13 src/Data/Schematic/Utils.hs−42 src/Data/Schematic/Validation.hs−1

schematic.cabal+2−1

@@ -14,6 +14,7 @@ cabal-version: >=1.10

1414

1515library

1616 exposed-modules: Data.Schematic

17+ , Data.Schematic.DSL

1718 , Data.Schematic.Instances

1819 , Data.Schematic.JsonSchema

1920 , Data.Schematic.Helpers

@@ -22,7 +23,6 @@ library

2223 , Data.Schematic.Path

2324 , Data.Schematic.Schema

2425 , Data.Schematic.Validation

25− , Data.Schematic.Utils

2626 ghc-options: -Wall

2727 default-extensions: ConstraintKinds

2828 , DataKinds

@@ -70,6 +70,7 @@ library

7070 , singletons >= 2.2

7171 , smallcheck

7272 , tagged

73+ , template-haskell

7374 , text

7475 , union

7576 , unordered-containers

src/Data/Schematic.hs+1−63

@@ -7,7 +7,6 @@ module Data.Schematic

77 , module Data.Schematic.Lens

88 , module Data.Schematic.Migration

99 , module Data.Schematic.Schema

10− , module Data.Schematic.Utils

1110 , decodeAndValidateJson

1211 , parseAndValidateJson

1312 , parseAndValidateJsonBy

@@ -28,23 +27,15 @@ import Data.Aeson as J

2827import Data.Aeson.Types as J

2928import Data.ByteString.Lazy as BL

3029import Data.Functor.Identity as F

31−import Data.Kind

30+import Data.Schematic.DSL

3231import Data.Schematic.Helpers

3332import Data.Schematic.JsonSchema

3433import Data.Schematic.Lens

3534import Data.Schematic.Migration

3635import Data.Schematic.Schema

37−import Data.Schematic.Utils

3836import Data.Schematic.Validation

39−import Data.Scientific

4037import Data.Singletons.Prelude hiding ((:.))

41−import Data.Singletons.TypeLits

42−import Data.Tagged

4338import Data.Text as T

44−import Data.Union

45−import qualified Data.Vector as V

46−import Data.Vinyl as V

47−import Data.Vinyl.Functor

4839

4940

5041parseAndValidateJson

@@ -135,56 +126,3 @@ decodeAndValidateVersionedWithPureMList

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

136127decodeAndValidateVersionedWithPureMList a b c =

137128 runIdentity $ decodeAndValidateVersionedWithMList a b c

138−

139−-- convenience helpers

140−

141−type Constructor a

142− = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

143− => Rec (Tagged (FieldsOf a) :. FieldRepr) b

144− -> JsonRepr ('SchemaObject (FieldsOf a))

145−

146−withRepr :: Constructor a

147−withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

148−

149−class Representable s where

150− type Repr s :: Type

151− construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)

152−

153−instance SingI so => Representable ('SchemaObject so) where

154− type Repr ('SchemaObject so) = Rec FieldRepr so

155− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o

156−

157−instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where

158− type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)

159− construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a

160−

161−instance SingI cs => Representable ('SchemaText cs) where

162− type Repr ('SchemaText cs) = Text

163− construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t

164−

165−instance SingI cs => Representable ('SchemaNumber cs) where

166− type Repr ('SchemaNumber cs) = Scientific

167− construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n

168−

169−instance Representable 'SchemaBoolean where

170− type Repr 'SchemaBoolean = Bool

171− construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b

172−

173−instance SingI so => Representable ('SchemaOptional so) where

174− type Repr ('SchemaOptional so) = Maybe (JsonRepr so)

175− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o

176−

177−instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where

178− type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)

179− construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u

180−

181−type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where

182− FieldsOf ('SchemaObject fs) = fs

183−

184−type FieldConstructor fn =

185− forall fs. (Representable (ByField fn fs (FIndex fn fs)))

186− => Repr (ByField fn fs (FIndex fn fs))

187− -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))

188−

189−field :: forall fn. KnownSymbol fn => FieldConstructor fn

190−field = Compose . Tagged . construct (sing :: Sing fn) Proxy

src/Data/Schematic/DSL.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

3+module Data.Schematic.DSL where

5+import Data.Kind

6+import Data.Schematic.Lens

7+import Data.Schematic.Migration

8+import Data.Schematic.Schema

9+import Data.Scientific

10+import Data.Singletons

11+import Data.Singletons.Prelude hiding ((:.))

12+import Data.Singletons.TypeLits

13+import Data.Tagged

14+import Data.Text as T

15+import Data.Union

16+import qualified Data.Vector as V

17+import Data.Vinyl

18+import Data.Vinyl.Functor

19+

20+

21+

22+type Constructor a

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

24+ => Rec (Tagged (FieldsOf a) :. FieldRepr) b

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

26+

27+withRepr :: Constructor a

28+withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

29+

30+class Representable s where

31+ type Repr s :: Type

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

33+

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

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

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

37+

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

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

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

41+

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

43+ type Repr ('SchemaText cs) = Text

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

45+

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

47+ type Repr ('SchemaNumber cs) = Scientific

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

49+

50+instance Representable 'SchemaBoolean where

51+ type Repr 'SchemaBoolean = Bool

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

53+

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

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

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

57+

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

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

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

61+

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

63+ FieldsOf ('SchemaObject fs) = fs

64+

65+type FieldConstructor fn =

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

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

68+ -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))

69+

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

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

src/Data/Schematic/Path.hs+4−13

@@ -2,7 +2,6 @@ module Data.Schematic.Path where

33import Data.Foldable as F

44import Data.Monoid

5−import Data.Schematic.Utils

65import Data.Singletons

76import Data.Singletons.Prelude

87import Data.Singletons.TypeLits

@@ -12,16 +11,8 @@ import Data.Text as T

1211data PathSegment = Key Symbol | Ix Nat

1312

1413data instance Sing (jp :: PathSegment) where

15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)

16− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)

17−

18−instance (KnownSymbol k, Known (Sing k))

19− => Known (Sing ('Key k)) where

20− known = SKey known

21−

22−instance (KnownNat n, Known (Sing n))

23− => Known (Sing ('Ix n)) where

24− known = SIx known

14+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)

15+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)

2516

2617data DemotedPathSegment = DKey Text | DIx Integer

2718 deriving (Show)

@@ -37,8 +28,8 @@ demotePath = go []

3728 go acc SNil = acc

3829 go acc (SCons p ps) = go (acc ++ [demote p]) ps

3930 demote :: Sing (ps :: PathSegment) -> DemotedPathSegment

40− demote (SKey s) = DKey $ T.pack $ symbolVal s

41− demote (SIx n) = DIx $ natVal n

31+ demote (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s

32+ demote (SIx n) = DIx $ withKnownNat n $ natVal n

4233

4334demotedPathToText :: [DemotedPathSegment] -> JSONPath

4435demotedPathToText = JSONPath . F.foldl' renderPathSegment ""

src/Data/Schematic/Utils.hsdeleted−42

@@ -1,42 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−

3−module Data.Schematic.Utils where

4−

5−import Data.Proxy

6−import Data.Singletons

7−import Data.Singletons.Prelude

8−import Data.Singletons.TypeLits

9−import Data.Vinyl hiding (Dict)

10−

11−

12−class Known a where

13− known :: a

14−

15−instance Known (Proxy a) where

16− known = Proxy

17−

18−instance KnownNat n => Known (Sing n) where

19− known = SNat

20−

21−instance KnownSymbol s => Known (Sing s) where

22− known = SSym

23−

24−instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where

25− known = STuple2 known known

26−

27−instance Known (Sing '[]) where known = SNil

28−

29−instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where

30− known = SCons known known

31−

32−instance Known (Rec Sing '[]) where

33− known = RNil

34−

35−instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where

36− known = known :& known

37−

38−data Dict c where

39− Dict :: c => Dict c

40−

41−instance c => Known (Dict c) where

42− known = Dict

src/Data/Schematic/Validation.hs−1

@@ -7,7 +7,6 @@ import Data.Functor.Identity

77import Data.Monoid

88import Data.Schematic.Path

99import Data.Schematic.Schema

10−import Data.Schematic.Utils ()

1110import Data.Scientific

1211import Data.Singletons.Prelude

1312import Data.Singletons.TypeLits