git.iko.soy/typeable/schematic
on union help sign in
typeable/schematic/src/Data/Schematic.hs
200 lines 6.6 kB history raw
1{-# OPTIONS -fprint-explicit-kinds #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4module Data.Schematic
5 ( module Data.Schematic.JsonSchema
6 , module Data.Schematic.Helpers
7 , module Data.Schematic.Lens
8 , module Data.Schematic.Migration
9 , module Data.Schematic.Schema
10 , module Data.Schematic.Utils
11 , decodeAndValidateJson
12 , parseAndValidateJson
13 , parseAndValidateJsonBy
14 , parseAndValidateTopVersionJson
15 , parseAndValidateWithMList
16 , decodeAndValidateVersionedWithMList
17 , decodeAndValidateVersionedWithPureMList
18 , isValid
19 , isDecodingError
20 , isValidationError
21 , ParseResult(..)
22 , withRepr
23 , field
24 , (<:&>)
25 ) where
27import Control.Applicative
28import Control.Monad.Validation
29import Data.Aeson as J
30import Data.Aeson.Types as J
31import Data.ByteString.Lazy as BL
32import Data.Functor.Identity
33import Data.Kind
34import Data.Schematic.Helpers
35import Data.Schematic.JsonSchema
36import Data.Schematic.Lens
37import Data.Schematic.Migration
38import Data.Schematic.Schema
39import Data.Schematic.Utils
40import Data.Schematic.Validation
41import Data.Scientific
42import Data.Singletons.Prelude
43import Data.Singletons.TypeLits
44import Data.Tagged
45import Data.Text as T
46import Data.Union
47import qualified Data.Vector as V
48import Data.Vinyl
51parseAndValidateJson
52 :: forall schema
53 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
54 => J.Value
55 -> ParseResult (JsonRepr schema)
56parseAndValidateJson v =
57 case parseEither parseJSON v of
58 Left s -> DecodingError $ T.pack s
59 Right jsonRepr ->
60 let
61 validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
62 res = runIdentity . runValidationTEither $ validate
63 in case res of
64 Left em -> ValidationError em
65 Right () -> Valid jsonRepr
67parseAndValidateJsonBy
68 :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
69 => proxy schema
70 -> J.Value
71 -> ParseResult (JsonRepr schema)
72parseAndValidateJsonBy _ = parseAndValidateJson
74parseAndValidateTopVersionJson
75 :: forall proxy (v :: Versioned)
76 . (SingI (TopVersion (AllVersions v)))
77 => proxy v
78 -> J.Value
79 -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
80parseAndValidateTopVersionJson _ v =
81 case parseEither parseJSON v of
82 Left s -> DecodingError $ T.pack s
83 Right jsonRepr ->
84 let
85 validate =
86 validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr
87 res = runIdentity . runValidationTEither $ validate
88 in case res of
89 Left em -> ValidationError em
90 Right () -> Valid jsonRepr
92parseAndValidateWithMList
93 :: Monad m
94 => MList m revisions
95 -> J.Value
96 -> m (ParseResult (JsonRepr (Head revisions)))
97parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v
98parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
99 Valid a -> pure $ Valid a
100 DecodingError _ -> do
101 pr <- parseAndValidateWithMList tl v
102 let pr' = f <$> pr
103 sequence pr'
104 ValidationError _ -> do
105 pr <- parseAndValidateWithMList tl v
106 let pr' = f <$> pr
107 sequence pr'
109decodeAndValidateJson
110 :: forall schema
111 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
112 => BL.ByteString
113 -> ParseResult (JsonRepr schema)
114decodeAndValidateJson bs = case decode bs of
115 Nothing -> DecodingError "malformed json"
116 Just x -> parseAndValidateJson x
118type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
119 MapSnd '[] = '[]
120 MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
122decodeAndValidateVersionedWithMList
123 :: Monad m
124 => proxy versioned
125 -> MList m (MapSnd (AllVersions versioned))
126 -> BL.ByteString
127 -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))
128decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
129 Nothing -> pure $ DecodingError "malformed json"
130 Just x -> parseAndValidateWithMList mlist x
132decodeAndValidateVersionedWithPureMList
133 :: proxy versioned
134 -> MList Identity (MapSnd (AllVersions versioned))
135 -> BL.ByteString
136 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
137decodeAndValidateVersionedWithPureMList a b c =
138 runIdentity $ decodeAndValidateVersionedWithMList a b c
140-- convenience helpers
142type 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))
147withRepr :: Constructor a
148withRepr = ReprObject . unTagged . fmap fcast
150(<:&>)
151 :: Applicative m
152 => m (FieldRepr fns)
153 -> m (Rec FieldRepr b)
154 -> m (Rec FieldRepr (fns ': b))
155(<:&>) = liftA2 (:&)
157infixr 7 <:&>
159class Representable s where
160 type Repr s :: Type
161 construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
163instance SingI so => Representable ('SchemaObject so) where
164 type Repr ('SchemaObject so) = Rec FieldRepr so
165 construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
167instance (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
171instance SingI cs => Representable ('SchemaText cs) where
172 type Repr ('SchemaText cs) = Text
173 construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
175instance SingI cs => Representable ('SchemaNumber cs) where
176 type Repr ('SchemaNumber cs) = Scientific
177 construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
179instance Representable 'SchemaBoolean where
180 type Repr 'SchemaBoolean = Bool
181 construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
183instance SingI so => Representable ('SchemaOptional so) where
184 type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
185 construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
187instance 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
191type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
192 FieldsOf ('SchemaObject fs) = fs
194type 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))))
199field :: forall fn. KnownSymbol fn => FieldConstructor fn
200field = Tagged . construct (sing :: Sing fn) Proxy