Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions schematic.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -65,7 +65,7 @@ library
, TypeOperators
, TypeSynonymInstances
, UndecidableInstances
build-depends: base >=4.11 && <4.12
build-depends: base >=4.11 && <4.13
, bytestring
, aeson >= 1
, containers
Expand Down Expand Up @@ -95,7 +95,7 @@ test-suite spec
default-language: Haskell2010
build-depends: HUnit
, aeson >= 1
, base >=4.11 && <4.12
, base >=4.11 && <4.13
, bytestring
, containers
, hjsonschema
Expand Down
13 changes: 11 additions & 2 deletions src/Data/Schematic/DSL.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}

module Data.Schematic.DSL where

Expand All @@ -17,11 +18,19 @@ import Data.Vinyl
import Data.Vinyl.Functor


#if MIN_VERSION_base(4,12,0)
type Constructor a
= forall fields b. (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
= forall fields b
. (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
=> Rec (Tagged fields :. FieldRepr) b
-> JsonRepr ('SchemaObject fields)

#else
type Constructor a
= forall fields b
. (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
=> Rec (Tagged fields :. FieldRepr) b
-> JsonRepr ('SchemaObject fields)
#endif
withRepr :: Constructor a
withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

Expand Down
12 changes: 10 additions & 2 deletions src/Data/Schematic/Migration.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Schematic.Migration where

Expand All @@ -8,7 +9,7 @@ import Data.Schematic.DSL
import Data.Schematic.Lens
import Data.Schematic.Path
import Data.Schematic.Schema
import Data.Singletons.Prelude hiding (All, (:.))
import Data.Singletons.Prelude hiding ((:.), All)
import Data.Singletons.TypeLits
import Data.Tagged
import Data.Vinyl
Expand Down Expand Up @@ -156,10 +157,17 @@ data MList :: (Type -> Type) -> [Schema] -> Type where

infixr 7 :&&

#if MIN_VERSION_base(4,12,0)
migrateObject
:: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)
=> (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
-> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
#else
migrateObject
:: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
=> (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
-> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
#endif
migrateObject f = Tagged $ \(ReprObject r) -> do
res <- f $ rmap (Compose . Tagged) r
pure $ withRepr @('SchemaObject fs) res
Expand Down
15 changes: 12 additions & 3 deletions src/Data/Schematic/Schema.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}

module Data.Schematic.Schema where
Expand All @@ -12,8 +13,8 @@ import Data.Aeson.Types as J
import Data.HashMap.Strict as H
import Data.Kind
import Data.Maybe
import Data.Schematic.Instances ()
import Data.Schematic.Generator
import Data.Schematic.Instances ()
import Data.Scientific
import Data.Singletons.Prelude.List hiding (All, Union)
import Data.Singletons.TH
Expand Down Expand Up @@ -373,8 +374,16 @@ instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
show (ReprArray v) = "ReprArray " P.++ show v

#if MIN_VERSION_base(4,12,0)
instance
( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs
, RecordToList fs )
=> Show (JsonRepr ('SchemaObject fs)) where
show (ReprObject fs) = "ReprObject " P.++ show fs
#else
instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
show (ReprObject fs) = "ReprObject " P.++ show fs
#endif

instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
show (ReprOptional s) = "ReprOptional " P.++ show s
Expand Down
5 changes: 5 additions & 0 deletions stack-13.7.yaml
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
resolver: lts-13.7
extra-deps:
- hjsonpointer-1.4.0@rev:0
- hjsonschema-1.9.0@rev:0
- validationt-0.2.1.0