versioning 0.2.0.0 → 0.3.0.0
raw patch · 10 files changed
+380/−235 lines, 10 filesdep ~base
Dependency ranges changed: base
Files
- ChangeLog.md +17/−0
- src/Versioning/Base.hs +96/−67
- src/Versioning/Internal/Decoding.hs +73/−24
- src/Versioning/Internal/Equality.hs +17/−0
- src/Versioning/Internal/Folding.hs +0/−41
- src/Versioning/JSON.hs +45/−5
- src/Versioning/Upgrade.hs +18/−11
- tests/Main.hs +25/−85
- tests/Tests/Versioning/Fixtures.hs +86/−0
- versioning.cabal +3/−2
ChangeLog.md view
@@ -1,5 +1,21 @@ # Revision history +## 0.3.0.0++- Encode `V` inductively++- Get rid of the overlapping instances (fixes a bug on GHC 8.2.1)++- Allow specifying the oldest supported version++- Switch to a multi-package cabal project++- Provide tools for working with Servant in the versioning-servant package++### Breaking changes++- `V` now starts at `V0` instead of `V1`+ ## 0.2.0.0 - Get the version number of a versioned value@@ -16,6 +32,7 @@ - `withAnyVersion` is now called `withJsonAnyVersion` - `withAnyVersionM` is now called `withJsonAnyVersionM`+ ## 0.1.0.0 - First version
src/Versioning/Base.hs view
@@ -26,79 +26,106 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-module Versioning.Base- ( V(..)- , GetV- , versionNumber- , Since- , Until- , NA- , na- , V1- , V2- , V3- , V4- , V5- , V6- , V7- , V8- , V9- , V10- , V11- , V12- , V13- , V14- , V15- , V16- , V17- , V18- , V19- , V20- )-where+module Versioning.Base (+ -- * Types+ V (..)+ , VPred+ , VSucc+ , VNat+ , VCmp+ , Since+ , Until+ , NA+ , na+ , V0+ , V1+ , V2+ , V3+ , V4+ , V5+ , V6+ , V7+ , V8+ , V9+ , V10+ , V11+ , V12+ , V13+ , V14+ , V15+ , V16+ , V17+ , V18+ , V19+ , V20+ -- * Functions+ , versionNumber+) where import Data.Proxy (Proxy (..))-import GHC.TypeNats (type (-), KnownNat, Nat, natVal)+import GHC.TypeNats (type (+), KnownNat, Nat, natVal) import Numeric.Natural (Natural) import Versioning.Internal.Base (Bare) -- | The version of a data model-newtype V = V Nat+data V = VZero | VSucc V deriving (Eq, Show) +-- | Get the previous version+type family VPred (v :: V) :: V where+ VPred ('VSucc v) = v+ VPred 'VZero = 'VZero++type VSucc = 'VSucc+ -- | Get the type-level natural of a version-type family GetV (v :: V) :: Nat where- GetV ('V n) = n+type family VNat (v :: V) :: Nat where+ VNat v = VNat' v 0 +type family VNat' (v :: V) (n :: Nat) :: Nat where+ VNat' 'VZero n = n+ VNat' ('VSucc v) n = VNat' v (n + 1)++-- | Compare two versions+type family VCmp (v :: V) (w :: V) :: Ordering where+ VCmp 'VZero 'VZero = 'EQ+ VCmp 'VZero v = 'LT+ VCmp v 'VZero = 'GT+ VCmp ('VSucc v) ('VSucc w) = VCmp v w+ -- | Get the version number of a versioned value-versionNumber :: forall a v. KnownNat (GetV v) => a v -> Natural-versionNumber _ = natVal (Proxy :: Proxy (GetV v))+versionNumber :: forall a v. KnownNat (VNat v) => a v -> Natural+versionNumber _ = natVal (Proxy :: Proxy (VNat v)) -- | This allows us to express that a field is only present since -- a given version. -- The first parameter is the version in which the field has been introduced, -- the second parameter is the actual version of the data-type.-type family Since (s :: V) (v :: V) a :: * where- Since ('V 1) ('V v) a = a- Since ('V s) ('V 1) a = NA- Since ('V s) ('V v) a = Since ('V (s - 1)) ('V (v - 1)) a+type family Since (s :: V) (v :: V) a where+ Since s v a = Since' (VCmp s v) a +type family Since' (o :: Ordering) a :: * where+ Since' 'LT a = a+ Since' 'EQ a = a+ Since' 'GT a = NA+ -- | This allows us to express that a field is only present until -- a given version. -- The first parameter is the last version in which the field is present, -- the second parameter is the actual version of the data-type.-type family Until (u :: V) (v :: V) a :: * where- Until ('V u) ('V 1) a = a- Until ('V 1) ('V v) a = NA- Until ('V u) ('V v) a = Until ('V (u - 1)) ('V (v - 1)) a+type family Until (u :: V) (v :: V) a where+ Until u v a = Until' (VCmp u v) a +type family Until' (o :: Ordering) a :: * where+ Until' 'GT a = a+ Until' 'EQ a = a+ Until' 'LT a = NA+ -- | A type indicating absence. -- The 'Maybe' is a hack needed to let aeson parse a record successfully even -- if a field of type 'NA' is missing.@@ -115,43 +142,45 @@ na :: NA na = Nothing --- Handy type synonyms to minimize parenthesis-type V1 = 'V 1+-- Version type synonyms+type V0 = 'VZero -type V2 = 'V 2+type V1 = 'VSucc V0 -type V3 = 'V 3+type V2 = 'VSucc V1 -type V4 = 'V 4+type V3 = 'VSucc V2 -type V5 = 'V 5+type V4 = 'VSucc V3 -type V6 = 'V 6+type V5 = 'VSucc V4 -type V7 = 'V 7+type V6 = 'VSucc V5 -type V8 = 'V 8+type V7 = 'VSucc V6 -type V9 = 'V 9+type V8 = 'VSucc V7 -type V10 = 'V 10+type V9 = 'VSucc V8 -type V11 = 'V 11+type V10 = 'VSucc V9 -type V12 = 'V 12+type V11 = 'VSucc V10 -type V13 = 'V 13+type V12 = 'VSucc V11 -type V14 = 'V 14+type V13 = 'VSucc V12 -type V15 = 'V 15+type V14 = 'VSucc V13 -type V16 = 'V 16+type V15 = 'VSucc V14 -type V17 = 'V 17+type V16 = 'VSucc V15 -type V18 = 'V 18+type V17 = 'VSucc V16 -type V19 = 'V 19+type V18 = 'VSucc V17 -type V20 = 'V 20+type V19 = 'VSucc V18++type V20 = 'VSucc V19
src/Versioning/Internal/Decoding.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -14,25 +15,33 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Versioning.Internal.Decoding- ( Applied+ ( -- * Types+ Applied , Apply , ApplyM , DecodableTo+ , DecodableToFrom , DecodeAnyVersion , Decoder (..) , WithAnyVersion+ , WithAnyVersionFrom+ -- * Decoding and upgrading , decodeAnyVersion+ , decodeAnyVersionFrom+ -- * Decoding and applying an action , withAnyVersion , withAnyVersionM+ , withAnyVersionFromM+ , withAnyVersionFrom ) where -import Data.Functor.Alt (Alt (..))-import Data.Functor.Identity (Identity (..))-import Data.Kind (Constraint, Type)+import Data.Functor.Alt (Alt (..))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Constraint, Type) import Versioning.Base-import Versioning.Internal.Folding (Decr)+import Versioning.Internal.Equality (type (==)) import Versioning.Upgrade -- | The result type of the action that has been applied to the decoded object@@ -49,19 +58,29 @@ newtype Decoder dec enc t a = Decoder (forall v. dec (a v) => enc -> t (a v)) -- | Handy constraint synonym to be used with 'decodeAnyVersion'-type DecodableTo dec v a = DecodeAnyVersion v v a dec+type DecodableTo dec v a = DecodableToFrom V0 dec v a --- | Decode by trying all the versions decrementally--- and upgrade the decoded object to the newest version.+type DecodableToFrom from dec v a = DecodeAnyVersionFrom from v v a dec+ decodeAnyVersion :: forall v a dec enc t . (Alt t, Applicative t, DecodableTo dec v a) => Decoder dec enc t a -> enc -> t (a v)-decodeAnyVersion = decodeAnyVersion' @v @v @a @dec+decodeAnyVersion = decodeAnyVersionFrom @V0 -- | Decode by trying all the versions decrementally+-- and upgrade the decoded object to the newest version.+decodeAnyVersionFrom+ :: forall from v a dec enc t+ . (Alt t, Applicative t, DecodableToFrom from dec v a)+ => Decoder dec enc t a+ -> enc+ -> t (a v)+decodeAnyVersionFrom = decodeAnyVersion' @(from == v) @from @v @v++-- | Decode by trying all the versions decrementally -- and apply an action to the decoded object at its original version. withAnyVersionM :: forall v c a dec enc m t@@ -70,8 +89,19 @@ -> ApplyM m a c -> enc -> m (t (Applied c a))-withAnyVersionM = withAnyVersion' @v @a @c @dec+withAnyVersionM = withAnyVersionFromM @V0 @v @c +-- | Like 'withAnyVersionM', with an additional type-parameter+-- indicating the oldest version you want to be able to decode+withAnyVersionFromM+ :: forall from v c a dec enc m t+ . (WithAnyVersionFrom from v a c dec, Alt t, Applicative t, Traversable t, Applicative m, c (a v))+ => Decoder dec enc t a+ -> ApplyM m a c+ -> enc+ -> m (t (Applied c a))+withAnyVersionFromM = withAnyVersion' @(from == v) @from @v @a @c @dec+ -- | Pure version of 'withAnyVersionM'. withAnyVersion :: forall v c a dec enc t@@ -83,36 +113,55 @@ withAnyVersion dec action = runIdentity . withAnyVersionM @v @c @a dec (Identity . action) -class DecodeAnyVersion (v :: V) (w :: V) (a :: V -> Type) dec where+-- | Pure version of 'withAnyVersionFromM'.+withAnyVersionFrom+ :: forall from v c a dec enc t+ . (WithAnyVersionFrom from v a c dec, c (a v), Alt t, Applicative t, Traversable t)+ => Decoder dec enc t a+ -> Apply a c+ -> enc+ -> t (Applied c a)+withAnyVersionFrom dec action =+ runIdentity . withAnyVersionFromM @from @v @c @a dec (Identity . action)++type DecodeAnyVersion v w a dec = DecodeAnyVersionFrom V0 v w a dec++type DecodeAnyVersionFrom from v w a dec = DecodeAnyVersion' (from == v) from v w a dec++class DecodeAnyVersion' (eq :: Bool) (from :: V) (v :: V) (w :: V) (a :: V -> Type) dec where decodeAnyVersion' :: (Alt t, Applicative t) => Decoder dec enc t a -> enc -> t (a w) -instance {-# OVERLAPPING #-} (dec (a V1), Upgrade V1 w a)- => DecodeAnyVersion V1 w a dec where- decodeAnyVersion' (Decoder decode) bs = upgrade @V1 @w <$> decode @V1 bs+instance (from ~ v, dec (a from), Upgrade from w a)+ => DecodeAnyVersion' 'True from v w a dec where+ decodeAnyVersion' (Decoder decode) bs = upgrade @from @w <$> decode @from bs -instance {-# OVERLAPPABLE #-} (DecodeAnyVersion (Decr v V1) w a dec, dec (a v), dec (a (Decr v V1)), Upgrade v w a)- => DecodeAnyVersion v w a dec where+instance (DecodeAnyVersion' (VPred v == from) from (VPred v) w a dec, dec (a v), dec (a (VPred v)), Upgrade v w a)+ => DecodeAnyVersion' 'False from v w a dec where decodeAnyVersion' decoder@(Decoder decode) bs = upgrade @v @w <$> decode @v bs- <!> decodeAnyVersion' @(Decr v V1) @w decoder bs+ <!> decodeAnyVersion' @(VPred v == from) @from @(VPred v) @w decoder bs -class WithAnyVersion (v :: V) (a :: V -> Type) c dec where+type WithAnyVersion v a c dec = WithAnyVersionFrom V0 v a c dec++type WithAnyVersionFrom from v a c dec = WithAnyVersion' (from == v) from v a c dec++class WithAnyVersion' (eq :: Bool) (from :: V) (v :: V) (a :: V -> Type) c dec where withAnyVersion' :: (Applicative m, Alt t, Applicative t, Traversable t, c (a v)) => Decoder dec enc t a -> ApplyM m a c -> enc -> m (t (Applied c a)) -instance {-# OVERLAPPING #-} (dec (a V1), c (a V1))- => WithAnyVersion V1 a c dec where- withAnyVersion' (Decoder decode) action bs = traverse action (decode @V1 bs)+instance (from ~ v, dec (a from), c (a from))+ => WithAnyVersion' 'True from v a c dec where+ withAnyVersion' (Decoder decode) action bs = traverse action (decode @from bs) -instance {-# OVERLAPPABLE #-} (WithAnyVersion (Decr v V1) a c dec, dec (a v), dec (a (Decr v V1)), c (a v), c (a (Decr v V1)))- => WithAnyVersion v a c dec where+instance (WithAnyVersion' (VPred v == from) from (VPred v) a c dec, dec (a v), dec (a (VPred v)), c (a v), c (a (VPred v)))+ => WithAnyVersion' 'False from v a c dec where withAnyVersion' dec@(Decoder decode) action bs = do res <- traverse action (decode @v bs)- next <- withAnyVersion' @(Decr v V1) @a @c dec action bs+ next <- withAnyVersion' @(VPred v == from) @from @(VPred v) @a @c dec action bs pure (res <!> next)
+ src/Versioning/Internal/Equality.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Versioning.Internal.Equality (type (==)) where++import Data.Type.Bool (type (&&))++-- | A type family to compute Boolean equality.+-- We can't use the one from "Data.Type.Equality" because+-- before 8.4 it was not poly-kinded.+type family (a :: k) == (b :: k) :: Bool where+ f a == g b = f == g && a == b+ a == a = 'True+ _ == _ = 'False
− src/Versioning/Internal/Folding.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-module Versioning.Internal.Folding- ( Decr- , Incr- )-where--import GHC.TypeLits-import GHC.TypeNats (type (-), type (+))--import Versioning.Base (V (..))---- | Decrement version until the target version is reached-type family Decr (c :: V) (v :: V) :: V where- Decr ('V c) ('V v) = Decr' (CmpNat c v) ('V c)--type family Decr' (o :: Ordering) (c :: V) :: V where- Decr' 'GT ('V c) = 'V (c - 1)- Decr' 'EQ ('V c) = 'V c- Decr' 'LT ('V c) = TypeError- ( 'Text "Cannot decrement "- ':<>: 'ShowType ('V c)- ':<>: 'Text " because the target is a higher version"- )---- | Increment version until the target version is reached-type family Incr (c :: V) (v :: V) :: V where- Incr ('V c) ('V v) = Incr' (CmpNat c v) ('V c)--type family Incr' (o :: Ordering) (c :: V) :: V where- Incr' 'LT ('V c) = 'V (c + 1)- Incr' 'EQ ('V c) = 'V c- Incr' 'GT ('V c) = TypeError- ( 'Text "Cannot increment "- ':<>: 'ShowType ('V c)- ':<>: 'Text " because the target is a lower version"- )
src/Versioning/JSON.hs view
@@ -3,30 +3,35 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Versioning.JSON- ( Applied+ ( -- * Types+ Applied , JsonDecodableTo+ , JsonDecodableToFrom+ -- * Decoding and upgrading , fromJsonAnyVersion , fromJsonAnyVersionStrict , fromJsonAnyVersionEither , fromJsonAnyVersionEitherStrict+ , fromJsonAnyVersionFrom+ -- * Decoding and appyling an action , withJsonAnyVersion , withJsonAnyVersionStrict , withJsonAnyVersionEither , withJsonAnyVersionEitherStrict+ , withJsonAnyVersionFrom , withJsonAnyVersionM , withJsonAnyVersionStrictM , withJsonAnyVersionEitherM , withJsonAnyVersionEitherStrictM+ , withJsonAnyVersionFromM ) where @@ -35,6 +40,7 @@ import qualified Data.ByteString as StrictBS import qualified Data.ByteString.Lazy as LazyBS +import Versioning.Base import Versioning.Internal.Decoding -- | Decode a JSON string by trying all the versions decrementally@@ -64,6 +70,15 @@ -> Either String (a v) fromJsonAnyVersionEitherStrict = decodeAnyVersion jsonEitherDecodeStrict +-- | Like 'fromJsonAnyVersion', with an additional type-parameter+-- indicating the oldest version you want to be able to decode+fromJsonAnyVersionFrom+ :: forall from v a+ . JsonDecodableToFrom from v a+ => LazyBS.ByteString+ -> Maybe (a v)+fromJsonAnyVersionFrom = decodeAnyVersionFrom @from jsonDecode+ -- | Decode a JSON string by trying all the versions decrementally -- and apply an action to the decoded object at its original version. withJsonAnyVersionM@@ -99,8 +114,19 @@ => ApplyM m a c -> StrictBS.ByteString -> m (Either String (Applied c a))-withJsonAnyVersionEitherStrictM = withAnyVersionM @v @c @a jsonEitherDecodeStrict+withJsonAnyVersionEitherStrictM =+ withAnyVersionM @v @c @a jsonEitherDecodeStrict +-- | Like 'withJsonAnyVersionM', with an additional type-parameter+-- indicating the oldest version you want to be able to decode+withJsonAnyVersionFromM+ :: forall from c a v m+ . (WithAnyVersionFrom from v a c FromJSON, Applicative m, c (a v))+ => ApplyM m a c+ -> LazyBS.ByteString+ -> m (Maybe (Applied c a))+withJsonAnyVersionFromM = withAnyVersionFromM @from @v @c @a jsonDecode+ -- | Decode a JSON string by trying all the versions decrementally -- and apply a pure function to the decoded object at its original version. withJsonAnyVersion@@ -138,6 +164,16 @@ -> Either String (Applied c a) withJsonAnyVersionEitherStrict = withAnyVersion @v @c @a jsonEitherDecodeStrict +-- | Like 'withJsonAnyVersion', with an additional type-parameter+-- indicating the oldest version you want to be able to decode+withJsonAnyVersionFrom+ :: forall from c a v+ . (WithAnyVersionFrom from v a c FromJSON, c (a v))+ => Apply a c+ -> LazyBS.ByteString+ -> Maybe (Applied c a)+withJsonAnyVersionFrom = withAnyVersionFrom @from @v @c @a jsonDecode+ -- | Decode with the aeson 'decode' function jsonDecode :: Decoder FromJSON LazyBS.ByteString Maybe a jsonDecode = Decoder decode@@ -155,4 +191,8 @@ jsonEitherDecodeStrict = Decoder eitherDecodeStrict -- | Handy constraint synonym to be used with 'fromJsonAnyVersion'-type JsonDecodableTo v a = DecodableTo FromJSON v a+type JsonDecodableTo v a = JsonDecodableToFrom V0 v a++-- | Like 'JsonDecodableTo', with an additional type-parameter+-- indicating the oldest version you want to be able to decode+type JsonDecodableToFrom from v a = DecodableToFrom from FromJSON v a
src/Versioning/Upgrade.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -8,16 +11,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Versioning.Upgrade- ( Adapt(..)- , Upgrade(..)+ ( Adapt (..)+ , Upgrade , upgrade ) where -import Data.Kind (Type)+import Data.Kind (Type) import Versioning.Base-import Versioning.Internal.Folding (Incr)+import Versioning.Internal.Equality (type (==)) -- | Adapt from a version to another class Adapt (v :: V) (w :: V) (a :: V -> Type) where@@ -25,20 +28,24 @@ -- | Upgrade from a lower to a higher version by calling 'adapt' on all -- the intermediary steps.-upgrade :: Upgrade v w a => a v -> a w-upgrade = upgrade'+upgrade :: forall v w a. Upgrade v w a => a v -> a w+upgrade = upgrade' @(v == w) +-- | This constraint specifies that a value of type 'a' can be upgraded+-- from version 'v' to version 'w'.+type Upgrade v w a = Upgrade' (v == w) v w a+ -- | Upgrade from a lower to a higher version by calling 'adapt' on all -- the intermediary steps. -- You do not need to define any instance. -- They are derived automatically if all the intermediary -- 'Adapt' instances are defined.-class Upgrade (v :: V) (w :: V) (a :: V -> Type) where+class Upgrade' (eq :: Bool) (v :: V) (w :: V) (a :: V -> Type) where upgrade' :: a v -> a w -instance {-# OVERLAPS #-} Upgrade v v a where+instance (v ~ w) => Upgrade' 'True v w a where upgrade' x = x -instance {-# OVERLAPPABLE #-} (Adapt v (Incr v w) a, Upgrade (Incr v w) w a)- => Upgrade v w a where- upgrade' x = upgrade' @(Incr v w) @w (adapt @v @(Incr v w) x)+instance (Adapt v (VSucc v) a, Upgrade' (VSucc v == w) (VSucc v) w a)+ => Upgrade' 'False v w a where+ upgrade' x = upgrade' @(VSucc v == w) @(VSucc v) @w (adapt @v @(VSucc v) x)
tests/Main.hs view
@@ -1,110 +1,50 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-} module Main where -import Data.Aeson-import qualified Data.ByteString.Lazy as LazyBS-import GHC.Generics (Generic) import Test.Hspec import Versioning.Base import Versioning.JSON import Versioning.Upgrade +import Tests.Versioning.Fixtures (Foo (..), foo0, foo2, fooJsonV0,+ fooJsonV2)+ main :: IO () main = hspec $ do describe "Versioning" $ do it "Can get the version number of a record" $- versionNumber foo1 `shouldBe` 1+ versionNumber foo0 `shouldBe` 0 describe "Upgrade" $ do it "Can upgrade across two versions" $- upgrade @V1 foo1 `shouldBe` foo3+ upgrade @V0 foo0 `shouldBe` foo2 describe "DecodeAnyVersion" $ do+ it "Can decode from V0" $+ fromJsonAnyVersion @V2 fooJsonV0 `shouldBe` Just foo2++ it "Can decode from V2" $+ fromJsonAnyVersion @V2 fooJsonV2 `shouldBe` Just foo2++ describe "DecodeAnyVersionFrom" $ do it "Can decode from V1" $- fromJsonAnyVersion @V3 fooJsonV1 `shouldBe` Just foo3+ fromJsonAnyVersionFrom @V1 @V2 fooJsonV2 `shouldBe` Just foo2 - it "Can decode from V3" $- fromJsonAnyVersion @V3 fooJsonV3 `shouldBe` Just foo3+ it "Should not decode V0" $+ fromJsonAnyVersionFrom @V1 @V2 fooJsonV0 `shouldBe` (Nothing :: Maybe (Foo V2)) describe "WithAnyVersion" $ do -- Decode a Foo and return its string representation without upgrading it it "Can apply a function on the decoded object" $ do- let Just res = withJsonAnyVersion @Show @Foo @V3 show fooJsonV1- res `shouldBe` show foo1--data Foo v = Foo- { always :: Int -- this field exists in all versions- , sinceV2 :: Since V2 v Bool -- this field has been introduced in V2- , sinceV3 :: Since V3 v String -- this field has been introduced in V3- , untilV2 :: Until V2 v Double -- this field has been removed in V3- } deriving (Generic)--deriving instance Eq (Foo V1)--deriving instance Eq (Foo V2)--deriving instance Eq (Foo V3)--instance FromJSON (Foo V1)--instance FromJSON (Foo V2)--instance FromJSON (Foo V3)--deriving instance Show (Foo V1)--deriving instance Show (Foo V2)--deriving instance Show (Foo V3)---- How to upcast from V1 to V2-instance Adapt V1 V2 Foo where- adapt foo = foo { sinceV2 = True- , sinceV3 = na- , untilV2 = untilV2 foo- }---- How to upcast from V2 to V3-instance Adapt V2 V3 Foo where- adapt foo = foo { sinceV2 = sinceV2 foo- , sinceV3 = "hello"- , untilV2 = na- }--type instance Applied Show a = String---- | A 'Foo' at version V1-foo1 :: Foo V1-foo1 = Foo- { always = 1- , sinceV2 = na- , sinceV3 = na- , untilV2 = 3.14- }---- | A 'Foo' at version V3-foo3 :: Foo V3-foo3 = Foo- { always = 1- , sinceV2 = True- , sinceV3 = "hello"- , untilV2 = Nothing- }+ let Just res = withJsonAnyVersion @Show @Foo @V2 show fooJsonV0+ res `shouldBe` show foo0 -fooJsonV1 :: LazyBS.ByteString-fooJsonV1 = "{\"always\":1, \"untilV2\": 3.14}"+ describe "WithAnyVersionFrom" $ do+ it "Can apply a function on the decoded object" $ do+ let Just res = withJsonAnyVersionFrom @V1 @Show @Foo @V2 show fooJsonV2+ res `shouldBe` show foo2 -fooJsonV3 :: LazyBS.ByteString-fooJsonV3 = "{\"always\":1, \"sinceV2\": true, \"sinceV3\": \"hello\"}"+ it "Should not decode V0" $ do+ let res = withJsonAnyVersionFrom @V1 @Show @Foo @V2 show fooJsonV0+ res `shouldBe` (Nothing :: Maybe String)
+ tests/Tests/Versioning/Fixtures.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Tests.Versioning.Fixtures where++import Data.Aeson+import qualified Data.ByteString.Lazy as LazyBS+import GHC.Generics (Generic)++import Versioning.Base+import Versioning.JSON+import Versioning.Upgrade++data Foo v = Foo+ { always :: Int -- this field exists in all versions+ , sinceV1 :: Since V1 v Bool -- this field has been introduced in V1+ , sinceV2 :: Since V2 v String -- this field has been introduced in V2+ , untilV1 :: Until V1 v Double -- this field has been removed in V2+ } deriving (Generic)++deriving instance Eq (Foo V0)++deriving instance Eq (Foo V1)++deriving instance Eq (Foo V2)++instance FromJSON (Foo V0)++instance FromJSON (Foo V1)++instance FromJSON (Foo V2)++deriving instance Show (Foo V0)++deriving instance Show (Foo V1)++deriving instance Show (Foo V2)++-- How to upcast from V1 to V2+instance Adapt V0 V1 Foo where+ adapt foo = foo { sinceV1 = True+ , sinceV2 = na+ , untilV1 = untilV1 foo+ }++-- How to upcast from V2 to V3+instance Adapt V1 V2 Foo where+ adapt foo = foo { sinceV1 = sinceV1 foo+ , sinceV2 = "hello"+ , untilV1 = na+ }++type instance Applied Show a = String++-- | A 'Foo' at version V0+foo0 :: Foo V0+foo0 = Foo+ { always = 1+ , sinceV1 = na+ , sinceV2 = na+ , untilV1 = 3.14+ }++-- | A 'Foo' at version V2+foo2 :: Foo V2+foo2 = Foo+ { always = 1+ , sinceV1 = True+ , sinceV2 = "hello"+ , untilV1 = Nothing+ }++fooJsonV0 :: LazyBS.ByteString+fooJsonV0 = "{\"always\":1, \"untilV1\": 3.14}"++fooJsonV2 :: LazyBS.ByteString+fooJsonV2 = "{\"always\":1, \"sinceV1\": true, \"sinceV2\": \"hello\"}"
versioning.cabal view
@@ -1,5 +1,5 @@ name: versioning-version: 0.2.0.0+version: 0.3.0.0 synopsis: Type-safe data versioning. description: This package provides various tools to deal with data versioning in a type-safe way.@@ -18,9 +18,9 @@ exposed-modules: Versioning.Base , Versioning.Internal.Base , Versioning.Internal.Decoding- , Versioning.Internal.Folding , Versioning.Upgrade , Versioning.JSON+ other-modules: Versioning.Internal.Equality build-depends: base >=4.10 && <4.12 , aeson >=1.0 && <1.5 , bytestring >=0.10 && <0.11@@ -32,6 +32,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs+ other-modules: Tests.Versioning.Fixtures build-depends: base >=4.10 && <4.12 , aeson >=1.0 && <1.5 , bytestring >=0.10 && <0.11