packages feed

schematic 0.3.2.0 → 0.4.0.0

raw patch · 15 files changed

+284/−153 lines, 15 filesdep +template-haskelldep +union

Dependencies added: template-haskell, union

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for schematic +## 0.4.0.0 -- 2017-10-17++Object building DSL, more convenience helpers, MCons simplified with Tagged+ ## 0.3.2.0 -- 2017-10-02  Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.
schematic.cabal view
@@ -1,5 +1,5 @@ name:                schematic-version:             0.3.2.0+version:             0.4.0.0 synopsis:            JSON-biased spec and validation tool license:             BSD3 license-file:        LICENSE@@ -14,6 +14,7 @@  library   exposed-modules:     Data.Schematic+                     , Data.Schematic.DSL                      , Data.Schematic.Instances                      , Data.Schematic.JsonSchema                      , Data.Schematic.Helpers@@ -22,7 +23,6 @@                      , Data.Schematic.Path                      , Data.Schematic.Schema                      , Data.Schematic.Validation-                     , Data.Schematic.Utils   ghc-options:       -Wall   default-extensions:  ConstraintKinds                      , DataKinds@@ -70,7 +70,9 @@                      , singletons >= 2.2                      , smallcheck                      , tagged+                     , template-haskell                      , text+                     , union                      , unordered-containers                      , validationt >= 0.1.0.1                      , vector
src/Data/Schematic.hs view
@@ -7,7 +7,6 @@   , module Data.Schematic.Lens   , module Data.Schematic.Migration   , module Data.Schematic.Schema-  , module Data.Schematic.Utils   , decodeAndValidateJson   , parseAndValidateJson   , parseAndValidateJsonBy@@ -19,21 +18,24 @@   , isDecodingError   , isValidationError   , ParseResult(..)+  , withRepr+  , field   ) where  import Control.Monad.Validation import Data.Aeson as J import Data.Aeson.Types as J import Data.ByteString.Lazy as BL-import Data.Functor.Identity-import Data.Schematic.JsonSchema+import Data.Functor.Identity as F+import Data.Schematic.DSL import Data.Schematic.Helpers+import Data.Schematic.JsonSchema import Data.Schematic.Lens import Data.Schematic.Migration import Data.Schematic.Schema-import Data.Schematic.Utils import Data.Schematic.Validation-import Data.Singletons.Prelude+import Data.Singletons.Prelude hiding ((:.))+import Data.Tagged import Data.Text as T  @@ -84,7 +86,8 @@   -> J.Value   -> m (ParseResult (JsonRepr (Head revisions))) parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v-parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of+parseAndValidateWithMList (Tagged f :&& tl) v =+  case parseAndValidateJsonBy Proxy v of     Valid a           -> pure $ Valid a     DecodingError _   -> do       pr <- parseAndValidateWithMList tl v@@ -120,7 +123,7 @@  decodeAndValidateVersionedWithPureMList   :: proxy versioned-  -> MList Identity (MapSnd (AllVersions versioned))+  -> MList F.Identity (MapSnd (AllVersions versioned))   -> BL.ByteString   -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))) decodeAndValidateVersionedWithPureMList a b c =
+ src/Data/Schematic/DSL.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.Schematic.DSL where++import           Data.Kind+import           Data.Schematic.Lens+import           Data.Schematic.Migration+import           Data.Schematic.Schema+import           Data.Scientific+import           Data.Singletons+import           Data.Singletons.Prelude hiding ((:.))+import           Data.Singletons.TypeLits+import           Data.Tagged+import           Data.Text as T+import           Data.Union+import qualified Data.Vector as V+import           Data.Vinyl+import           Data.Vinyl.Functor+++type Constructor a+  = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)+  => Rec (Tagged (FieldsOf a) :. FieldRepr) b+  -> JsonRepr ('SchemaObject (FieldsOf a))++withRepr :: Constructor a+withRepr = ReprObject . rmap (unTagged . getCompose) . fcast++class Representable s where+  constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)++instance SingI so => Representable ('SchemaObject so) where+  constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o++instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where+  constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a++instance SingI cs => Representable ('SchemaText cs) where+  constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t++instance SingI cs => Representable ('SchemaNumber cs) where+  constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n++instance Representable 'SchemaBoolean where+  constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b++instance SingI so => Representable ('SchemaOptional so) where+  constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o++instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where+  constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u++construct :: Sing s -> Repr s -> JsonRepr s+construct s r = case s of+  SSchemaObject _          -> ReprObject r+  SSchemaArray _ _         -> ReprArray r+  SSchemaText _            -> ReprText r+  SSchemaNumber _          -> ReprNumber r+  SSchemaBoolean           -> ReprBoolean r+  SSchemaOptional _        -> ReprOptional r+  SSchemaNull              -> ReprNull+  SSchemaUnion ss          -> case ss of+    SNil      -> error "unconstructable union"+    SCons _ _ -> ReprUnion r++type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where+  FieldsOf ('SchemaObject fs) = fs++type FieldConstructor fn =+  forall fs. (Representable (ByField fn fs (FIndex fn fs)))+  => Repr (ByField fn fs (FIndex fn fs))+  -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))++field :: forall fn. KnownSymbol fn => FieldConstructor fn+field = Compose . Tagged . constructField (sing :: Sing fn) Proxy++type family Repr (s :: Schema) = (ty :: Type) where+  Repr ('SchemaObject so) = Rec FieldRepr so+  Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)+  Repr ('SchemaText cs) = Text+  Repr ('SchemaNumber cs) = Scientific+  Repr 'SchemaBoolean = Bool+  Repr ('SchemaOptional so) = Maybe (JsonRepr so)+  Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
src/Data/Schematic/JsonSchema.hs view
@@ -16,6 +16,7 @@ import Data.Schematic.Schema as S import Data.Singletons import Data.Text+import Data.Traversable import JSONSchema.Draft4.Schema as D4 import JSONSchema.Validator.Draft4 as D4 @@ -62,31 +63,43 @@   :: forall proxy schema    . SingI schema   => proxy (schema :: S.Schema)-  -> D4.Schema-toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))-  { _schemaVersion = pure draft4 }+  -> Maybe D4.Schema+toJsonSchema _ = do+  js <- toJsonSchema' $ fromSing (sing :: Sing schema)+  pure $ js { _schemaVersion = pure draft4 }  toJsonSchema'   :: DemotedSchema-  -> D4.Schema+  -> Maybe D4.Schema toJsonSchema' = \case   DSchemaText tcs ->-    execState (traverse_ textConstraint tcs) $ emptySchema+    pure $ execState (traverse_ textConstraint tcs) $ emptySchema       { _schemaType = pure $ TypeValidatorString D4.SchemaString }   DSchemaNumber ncs ->-    execState (traverse_ numberConstraint ncs) $ emptySchema+    pure $ execState (traverse_ numberConstraint ncs) $ emptySchema       { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }-  DSchemaBoolean -> emptySchema-      { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }-  DSchemaObject objs -> emptySchema-      { _schemaType = pure $ TypeValidatorString D4.SchemaObject-      , _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s))-        <$> objs }-  DSchemaArray acs sch ->-    execState (traverse_ arrayConstraint acs) $ emptySchema-      { _schemaType = pure $ TypeValidatorString D4.SchemaArray-      , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }-  DSchemaNull -> emptySchema-      { _schemaType = pure $ TypeValidatorString D4.SchemaNull }-  DSchemaOptional sch -> emptySchema-      { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }+  DSchemaBoolean -> pure $ emptySchema+    { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }+  DSchemaObject objs -> do+    res <- for objs $ \(n,s) -> do+      s' <- toJsonSchema' s+      pure (n, s')+    pure $ emptySchema+      { _schemaType       = pure $ TypeValidatorString D4.SchemaObject+      , _schemaProperties = pure $ H.fromList res }+  DSchemaArray acs sch -> do+    res <- toJsonSchema' sch+    pure $ execState (traverse_ arrayConstraint acs) $ emptySchema+      { _schemaType  = pure $ TypeValidatorString D4.SchemaArray+      , _schemaItems = pure $ ItemsArray [res] }+  DSchemaNull -> pure $ emptySchema+    { _schemaType = pure $ TypeValidatorString D4.SchemaNull }+  DSchemaOptional sch -> do+    snull <- toJsonSchema' DSchemaNull+    sres <- toJsonSchema' sch+    pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }+  DSchemaUnion sch -> do+    schemaUnion <- traverse toJsonSchema' sch >>= \case+      [] -> Nothing+      x  -> Just x+    pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }
src/Data/Schematic/Lens.hs view
@@ -9,6 +9,7 @@   , FImage   , FSubset(..)   , obj+  , arr   , textRepr   , numberRepr   , boolRepr@@ -40,23 +41,23 @@   flens     :: Functor g     => proxy fn-    -> (FieldRepr '(fn, (ByField fn rs i)) -> g (FieldRepr '(fn, (ByField fn rs i))))-    -> Rec FieldRepr rs-    -> g (Rec FieldRepr rs)+    -> (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))+    -> Rec f rs+    -> g (Rec f rs)    -- | For Vinyl users who are not using the @lens@ package, we provide a getter.   fget     :: proxy fn-    -> Rec FieldRepr rs-    -> FieldRepr '(fn, (ByField fn rs i))+    -> Rec f rs+    -> f '(fn, (ByField fn rs i))    -- | For Vinyl users who are not using the @lens@ package, we also provide a   -- setter. In general, it will be unambiguous what field is being written to,   -- and so we do not take a proxy argument here.   fput-    :: FieldRepr '(fn, ByField fn rs i)-    -> Rec FieldRepr rs-    -> Rec FieldRepr rs+    :: f '(fn, ByField fn rs i)+    -> Rec f rs+    -> Rec f rs  instance FElem fn ('(fn, r) ': rs) 'Z where   type ByField fn ('(fn, r) ': rs) 'Z = r@@ -98,8 +99,7 @@ type Iso' s a = Iso s s a a  iso-  :: (s -> a)-  -> (b -> t)+  :: (s -> a) -> (b -> t)   -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# INLINE iso #-}@@ -116,24 +116,24 @@   -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)   fsubset     :: Functor g-    => (Rec FieldRepr rs -> g (Rec FieldRepr rs))-    -> Rec FieldRepr ss-    -> g (Rec FieldRepr ss)+    => (Rec f rs -> g (Rec f rs))+    -> Rec f ss+    -> g (Rec f ss)    -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record   -- to a smaller one by forgetting fields.   fcast-    :: Rec FieldRepr ss-    -> Rec FieldRepr rs+    :: Rec f ss+    -> Rec f rs   fcast = getConst . fsubset Const   {-# INLINE fcast #-}    -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of   -- a record to be replaced with different values.   freplace-    :: Rec FieldRepr rs-    -> Rec FieldRepr ss-    -> Rec FieldRepr ss+    :: Rec f rs+    -> Rec f ss+    -> Rec f ss   freplace rs = getIdentity . fsubset (\_ -> Identity rs)   {-# INLINE freplace #-} @@ -146,7 +146,7 @@   , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where   fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set     where-      set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss+      set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss       set ss (r :& rs) = fput r $ freplace rs ss  -- A bunch of @Iso@morphisms@@ -182,3 +182,8 @@  obj :: (SingI fields) => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields) obj = iso (\(ReprObject r) -> r) ReprObject++arr+  :: (SingI schema)+  => Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))+arr = iso (\(ReprArray r) -> r) ReprArray
src/Data/Schematic/Migration.hs view
@@ -5,6 +5,7 @@  import Data.Kind import Data.Schematic.Path+import Data.Tagged import Data.Schematic.Schema import Data.Singletons.Prelude hiding (All) import Data.Singletons.TypeLits@@ -138,12 +139,13 @@     -> Sing (ms :: [Migration]) -- a bunch of migrations     -> Sing ('Versioned s ms) +type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))+ data MList :: (* -> *) -> [Schema] -> Type where   MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]   (:&&)     :: (TopLevel s, SingI s)-    => proxy s-    -> (JsonRepr h -> m (JsonRepr s))+    => DataMigration s m h     -> MList m (h ': tl)     -> MList m (s ': h ': tl)
src/Data/Schematic/Path.hs view
@@ -2,7 +2,6 @@  import Data.Foldable as F import Data.Monoid-import Data.Schematic.Utils import Data.Singletons import Data.Singletons.Prelude import Data.Singletons.TypeLits@@ -12,16 +11,8 @@ data PathSegment = Key Symbol | Ix Nat  data instance Sing (jp :: PathSegment) where-  SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)-  SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)--instance (KnownSymbol k, Known (Sing k))-  => Known (Sing ('Key k)) where-  known = SKey known--instance (KnownNat n, Known (Sing n))-  => Known (Sing ('Ix n)) where-  known = SIx known+  SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)+  SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)  data DemotedPathSegment = DKey Text | DIx Integer   deriving (Show)@@ -37,8 +28,8 @@     go acc SNil = acc     go acc (SCons p ps) = go (acc ++ [demote p]) ps     demote :: Sing (ps :: PathSegment) -> DemotedPathSegment-    demote (SKey s) = DKey $ T.pack $ symbolVal s-    demote (SIx n) = DIx $ natVal n+    demote (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s+    demote (SIx n) = DIx $ withKnownNat n $ natVal n  demotedPathToText :: [DemotedPathSegment] -> JSONPath demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
src/Data/Schematic/Schema.hs view
@@ -5,7 +5,7 @@  module Data.Schematic.Schema where -import           Control.Applicative ()+import           Control.Applicative ((<|>)) import           Control.Monad import           Data.Aeson as J import           Data.Aeson.Types as J@@ -14,13 +14,15 @@ import           Data.Maybe import           Data.Schematic.Instances () import           Data.Scientific-import           Data.Singletons.Prelude.List hiding (All)+import           Data.Singletons.Prelude.List hiding (All, Union) import           Data.Singletons.TH import           Data.Singletons.TypeLits import           Data.Text as T+import           Data.Union import           Data.Vector as V import           Data.Vinyl hiding (Dict) import qualified Data.Vinyl.TypeLevel as V+import           GHC.Exts import           GHC.Generics (Generic) import           GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal) import           Prelude as P@@ -205,6 +207,7 @@   | SchemaArray [ArrayConstraint] Schema   | SchemaNull   | SchemaOptional Schema+  | SchemaUnion [Schema]   deriving (Generic)  data DemotedSchema@@ -215,6 +218,7 @@   | DSchemaArray [DemotedArrayConstraint] DemotedSchema   | DSchemaNull   | DSchemaOptional DemotedSchema+  | DSchemaUnion [DemotedSchema]   deriving (Generic)  data instance Sing (schema :: Schema) where@@ -225,6 +229,7 @@   SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)   SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)   SSchemaNull :: Sing 'SchemaNull+  SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)  instance SingI sl => SingI ('SchemaText sl) where   sing = SSchemaText sing@@ -240,6 +245,8 @@   sing = SSchemaObject sing instance SingI s => SingI ('SchemaOptional s) where   sing = SSchemaOptional sing+instance SingI s => SingI ('SchemaUnion s) where+  sing = SSchemaUnion sing  instance Eq (Sing ('SchemaText cs)) where _ == _ = True instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True@@ -248,6 +255,7 @@ instance Eq (Sing ('SchemaArray as s)) where _ == _ = True instance Eq (Sing ('SchemaObject cs)) where _ == _ = True instance Eq (Sing ('SchemaOptional s)) where _ == _ = True+instance Eq (Sing ('SchemaUnion s)) where _ == _ = True  instance SingKind Schema where   type Demote Schema = DemotedSchema@@ -258,12 +266,8 @@     SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)     SSchemaOptional s -> DSchemaOptional $ fromSing s     SSchemaNull -> DSchemaNull-    SSchemaObject cs -> let-      dem :: Sing (s :: [(Symbol, Schema)]) -> [(Text, DemotedSchema)]-      dem SNil              = []-      dem (SCons (STuple2 ss ssch) fs) = withKnownSymbol ss-        $ (T.pack (symbolVal ss), fromSing ssch) : dem fs-      in DSchemaObject $ dem cs+    SSchemaObject cs -> DSchemaObject $ fromSing cs+    SSchemaUnion ss -> DSchemaUnion $ fromSing ss   toSing = \case     DSchemaText cs -> case toSing cs of       SomeSing scs -> SomeSing $ SSchemaText scs@@ -277,6 +281,8 @@     DSchemaNull -> SomeSing SSchemaNull     DSchemaObject cs -> case toSing cs of       SomeSing scs -> SomeSing $ SSchemaObject scs+    DSchemaUnion ss -> case toSing ss of+      SomeSing sss -> SomeSing $ SSchemaUnion sss  data FieldRepr :: (Symbol, Schema) -> Type where   FieldRepr@@ -314,6 +320,10 @@   => Serial m (FieldRepr '(name, schema)) where   series = FieldRepr <$> series +type family USubsets (u :: [k]) :: Constraint where+  USubsets '[] = ()+  USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)+ data JsonRepr :: Schema -> Type where   ReprText :: Text -> JsonRepr ('SchemaText cs)   ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)@@ -322,7 +332,9 @@   ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)   ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)   ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)+  ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl)) +-- | Move to the union package instance Show (JsonRepr ('SchemaText cs)) where   show (ReprText t) = "ReprText " P.++ show t @@ -381,6 +393,22 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where   ReprOptional a == ReprOptional b = a == b +instance IsList (JsonRepr ('SchemaArray cs s)) where+  type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s+  fromList = ReprArray . GHC.Exts.fromList+  toList (ReprArray v) = GHC.Exts.toList v++instance Num (JsonRepr ('SchemaNumber cs)) where+  ReprNumber a + ReprNumber b = ReprNumber $ a + b+  ReprNumber a - ReprNumber b = ReprNumber $ a - b+  ReprNumber a * ReprNumber b = ReprNumber $ a * b+  abs (ReprNumber a) = ReprNumber $ abs a+  signum (ReprNumber a) = ReprNumber $ signum a+  fromInteger = ReprNumber . fromIntegral++instance IsString (JsonRepr ('SchemaText cs)) where+  fromString = ReprText . fromString+ fromOptional   :: SingI s   => Sing ('SchemaOptional s)@@ -388,6 +416,24 @@   -> Parser (Maybe (JsonRepr s)) fromOptional _ = parseJSON +parseUnion+  :: FromJSON (JsonRepr ('SchemaUnion ss))+  => sing (ss :: [Schema])+  -> Value+  -> Parser (JsonRepr ('SchemaUnion ss))+parseUnion _ val = parseJSON val++instance FromJSON (Union JsonRepr '[]) where+  parseJSON = fail "empty union"++instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where+  parseJSON val = (This <$> parseJSON val)+    <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))++instance ToJSON (Union JsonRepr as) where+  toJSON (This fa) = toJSON fa+  toJSON (That u)  = toJSON u+ instance SingI schema => J.FromJSON (JsonRepr schema) where   parseJSON value = case sing :: Sing schema of     SSchemaText _          -> withText "String" (pure . ReprText) value@@ -427,8 +473,10 @@             SSchemaOptional so -> case H.lookup fieldName h of               Just v -> withSingI so $ FieldRepr <$> parseJSON v               Nothing -> fail "schemaoptional"+            SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value           (fieldRepr :&) <$> demoteFields tl h       ReprObject <$> withObject "Object" (demoteFields fs) value+    SSchemaUnion ss -> parseUnion ss value  instance J.ToJSON (JsonRepr a) where   toJSON ReprNull         = J.Null@@ -449,6 +497,7 @@       fold = \case         RNil                   -> []         fr@(FieldRepr _) :& tl -> (extract fr) : fold tl+  toJSON (ReprUnion u) = toJSON u  class FalseConstraint a
− src/Data/Schematic/Utils.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Data.Schematic.Utils where--import Data.Proxy-import Data.Singletons-import Data.Singletons.Prelude-import Data.Singletons.TypeLits-import Data.Vinyl hiding (Dict)---class Known a where-  known :: a--instance Known (Proxy a) where-  known = Proxy--instance KnownNat n => Known (Sing n) where-  known = SNat--instance KnownSymbol s => Known (Sing s) where-  known = SSym--instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where-  known = STuple2 known known--instance Known (Sing '[]) where known = SNil--instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where-  known = SCons known known--instance Known (Rec Sing '[]) where-  known = RNil--instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where-  known = known :& known--data Dict c where-  Dict :: c => Dict c--instance c => Known (Dict c) where-  known = Dict
src/Data/Schematic/Validation.hs view
@@ -7,14 +7,15 @@ import Data.Monoid import Data.Schematic.Path import Data.Schematic.Schema-import Data.Schematic.Utils () import Data.Scientific import Data.Singletons.Prelude import Data.Singletons.TypeLits import Data.Text as T import Data.Traversable+import Data.Union import Data.Vector as V import Data.Vinyl+import Data.Vinyl.TypeLevel import Prelude as P import Text.Regex.TDFA @@ -199,9 +200,49 @@   ReprObject fs -> case sschema of     SSchemaObject _ -> go fs       where-        go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()+        go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()         go RNil                     = pure ()         go (f@(FieldRepr d) :& ftl) = do           let newPath = dpath <> [DKey (knownFieldName f)]           validateJsonRepr (knownFieldSchema f) newPath d           go ftl+  ReprUnion _ -> pure () -- FIXME+    -- case sschema of+    --   SSchemaUnion ss -> case ss of+    --     SCons s stl -> case umatch' s u of+    --       Nothing -> case urestrict u of+    --         Nothing ->+    --           fail "impossible to produce subUnion, please report this as a bug"+    --         Just x -> do+    --           let+    --             JSONPath path = demotedPathToText dpath+    --           case stl of+    --             SNil -> void $ vWarning $ mmSingleton path+    --               $ pure "union handling error, please report this as bug"+    --             SCons s' stl' ->+    --               validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath+    --                 $ toUnion (SCons s' stl') x+    --       Just x  -> validateJsonRepr s dpath x++-- subUnion+--   :: Sing (s ': stl)+--   -> (  USubset stl (s ': stl) (RImage stl (s ': stl))+--      => Union f (s ': stl)+--      -> Maybe (Union f stl) )+-- subUnion (SCons s stl) = urestrict++-- withUSubset+--   :: Sing (s ': stl)+--   -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))+--   -> Maybe (Union f stl)+-- withUSubset (SCons s stl) r = r++toUnion+  :: USubset s' (s ': ss) (RImage s' (s ': ss))+  => Sing (s ': ss)+  -> Union JsonRepr s'+  -> JsonRepr ('SchemaUnion (s ': ss))+toUnion _ = ReprUnion . urelax++umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)+umatch' _ u = umatch u
test/HelpersSpec.hs view
@@ -3,18 +3,12 @@ module HelpersSpec (spec, main) where  import Control.Lens-import Data.Aeson-import Data.ByteString.Char8 as C8-import Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Lens import Data.Foldable-import Data.Functor.Identity import Data.Monoid-import Data.Proxy import Data.Schematic import Data.Text as T import Data.Text.Lens-import Data.Vinyl import Test.Hspec
test/JsonSchemaSpec.hs view
@@ -1,6 +1,7 @@ module JsonSchemaSpec (spec, main) where  import Data.Aeson as J+import Data.Maybe import Data.Proxy import Data.Schematic import Data.Vinyl@@ -17,24 +18,16 @@  type SchemaExample = 'SchemaObject FieldsSchema -arrayData :: JsonRepr ArraySchema-arrayData = ReprArray [ReprNumber 13]--arrayField :: FieldRepr ArrayField-arrayField = FieldRepr arrayData--objectData :: Rec FieldRepr FieldsSchema-objectData = FieldRepr arrayData-  :& FieldRepr (ReprOptional (Just (ReprText "foo")))-  :& RNil- exampleData :: JsonRepr SchemaExample-exampleData = ReprObject objectData+exampleData = withRepr @SchemaExample $+     field @"foo" [ReprNumber 13]+  :& field @"bar" (pure (ReprText "foo"))+  :& RNil  spec :: Spec spec = do   it "validates simple schema" $ do-    let schema = D4.SchemaWithURI (toJsonSchema (Proxy @SchemaExample)) Nothing+    let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing     fetchHTTPAndValidate schema (toJSON exampleData) >>= \case       Left _ -> fail "failed to validate test example"       Right _ -> pure ()
test/LensSpec.hs view
@@ -1,7 +1,6 @@ module LensSpec (spec, main) where  import Control.Lens-import Data.Kind import Data.Proxy import Data.Schematic import Data.Vinyl@@ -15,8 +14,6 @@ type FieldsSchema =   '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField] -type SchemaExample = 'SchemaObject FieldsSchema- arrayData :: JsonRepr ArraySchema arrayData = ReprArray [ReprNumber 13] @@ -27,9 +24,6 @@ objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))   :& FieldRepr arrayData   :& RNil--exampleData :: JsonRepr SchemaExample-exampleData = ReprObject objectData  type BigRecord = Rec FieldRepr   '[ '("f1", 'SchemaNumber '[])
test/SchemaSpec.hs view
@@ -7,15 +7,21 @@ import Data.Functor.Identity import Data.Proxy import Data.Schematic+import Data.Tagged import Data.Vinyl import Test.Hspec  -type SchemaExample-  = 'SchemaObject-    '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))-     , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]+type SchemaExample = 'SchemaObject+  '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))+   , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))] +jsonExample :: JsonRepr SchemaExample+jsonExample = withRepr @SchemaExample+   $ field @"bar" (Just "bar")+  :& field @"foo" [12]+  :& RNil+ type TestMigration =   'Migration "test_revision"     '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))@@ -23,12 +29,6 @@  type VS = 'Versioned SchemaExample '[ TestMigration ] -jsonExample :: JsonRepr SchemaExample-jsonExample = ReprObject $-  FieldRepr (ReprArray [ReprNumber 12])-    :& FieldRepr (ReprOptional (Just (ReprText "bar")))-    :& RNil- schemaJson :: ByteString schemaJson = "{\"foo\": [13], \"bar\": null}" @@ -66,9 +66,7 @@   it "validates versioned json with a migration list" $ do     decodeAndValidateVersionedWithPureMList       (Proxy @VS)-      ((:&&)-        (Proxy @(SchemaByRevision "test_revision" VS))-        (const $ Identity topObject) MNil)+      (Tagged (const $ Identity topObject) :&& MNil)       schemaJson         `shouldSatisfy` isValid