DataVersion (empty) → 0.1.0.0

raw patch · 8 files changed

+314/−0 lines, 8 filesdep +DataVersiondep +QuickCheckdep +basesetup-changed

Dependencies added: DataVersion, QuickCheck, base, generic-lens, hspec, microlens

Files

• ChangeLog.md +3/−0
• DataVersion.cabal +59/−0
• LICENSE +7/−0
• README.md +16/−0
• Setup.hs +2/−0
• src/Data/Migration.hs +80/−0
• src/Data/Migration/Internal.hs +105/−0
• test/Spec.hs +42/−0

@@ -0,0 +1,3 @@+# Changelog for DataVersion++## Unreleased changes

@@ -0,0 +1,59 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 21c291662b767b5c5923f5b8dd4a621d30578be2dae431d97c7dd06383954ec5++name:           DataVersion+version:        0.1.0.0+synopsis:       Type safe data migrations+description:    Please see the README on GitHub at <https://github.com/agentultra/DataMigration#readme>+category:       Data+homepage:       https://github.com/agentultra/DataMigration#readme+bug-reports:    https://github.com/agentultra/DataMigration/issues+author:         Sandy Maguire, James King+maintainer:     james@agentultra.com+copyright:      2019 Sandy Maguire, James King+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/agentultra/DataMigration++library+  exposed-modules:+      Data.Migration+      Data.Migration.Internal+  other-modules:+      Paths_DataVersion+  hs-source-dirs:+      src+  default-extensions: DataKinds TypeFamilies QuantifiedConstraints DeriveGeneric MultiParamTypeClasses FlexibleContexts FlexibleInstances PolyKinds AllowAmbiguousTypes DuplicateRecordFields FunctionalDependencies GeneralizedNewtypeDeriving ScopedTypeVariables TypeApplications TypeOperators UndecidableInstances+  build-depends:+      base >=4.7 && <5+    , generic-lens >=1.1.0.0 && <2+    , microlens >=0.4.10 && <2+  default-language: Haskell2010++test-suite DataVersion-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_DataVersion+  hs-source-dirs:+      test+  default-extensions: DataKinds TypeFamilies QuantifiedConstraints DeriveGeneric MultiParamTypeClasses FlexibleContexts FlexibleInstances PolyKinds AllowAmbiguousTypes DuplicateRecordFields FunctionalDependencies GeneralizedNewtypeDeriving ScopedTypeVariables TypeApplications TypeOperators UndecidableInstances+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      DataVersion+    , QuickCheck+    , base >=4.7 && <5+    , hspec+  default-language: Haskell2010

@@ -0,0 +1,7 @@+Copyright (c) 2019 Sandy Maguire, James King++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,16 @@+# DataMigration++Type safe data migrations.++All you need to do is create a type family to index your record and+provide an instance of `Transform` to migrate your data between+versions.++Migrations are type-safe and the library uses generics to remove as+much boiler-plate as possible.++## Future Considerations++In the future this library will provide a high-level DSL to enable+better ergonomics around type errors so that you can see which fields+require specification in the migration.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,80 @@+{-|+Module : Data.Migration+Description : Type-safe migrations for data+Copyright : (c) Sandy Maguire, 2019+                James King, 2019+License : MIT+Maintainer : james@agentultra.com+Stability : experimental++To begin migrating your data start with a type family for your record+and index it with a natural number++@+    data family Foo (version :: Nat)++    newtype MyString = MyString { unMyString :: String }+       deriving (IsString, Show, Eq)++    data instance Foo 0+      = FooV0+        { _fooId :: Int+        , _fooName :: String+        }+      deriving (Generic, Show, Eq)++    data instance Foo 1+      = FooV1+      { _fooId        :: Int+      , _fooName      :: MyString+      , _fooHonorific :: String+      }+      deriving (Generic, Show, Eq)++    instance Transform Foo 0 where+      up   v = genericUp   v (const "esquire") (const MyString)+      down v = genericDown v (const unMyString)+@++You provide an instance of the Transform class for your type in order+to specify how to transform version /n/ to version /n + 1/ and back.++Presently only simple record types are supported. More to come in the+future.+-}+module Data.Migration where++import Data.Kind+import GHC.Generics+import GHC.TypeLits++import Data.Migration.Internal++-- | Implement this class on your type family instance to migrate+--   values of your type to the new version and back+class Transform (f :: Nat -> Type) (n :: Nat) where+  up   :: f n       -> f (n + 1)+  down :: f (n + 1) -> f n++-- | Using this function in your 'up' transformation ensures that you+-- only have to provide functions for fields that change or are added.+genericUp+    :: forall n src diff+     . ( diff ~ FieldDiff (Sort (RepToTree (Rep (src n)))) (Sort (RepToTree (Rep (src (n + 1)))))+       , GTransform diff (src n) (src (n + 1))+       , Generic (src (n + 1))+       , GUndefinedFields (Rep (src (n + 1)))+       )+    => src n -> Function diff (src n) (src (n + 1))+genericUp = gTransform @diff @_ @(src (n + 1)) undefinedFields++-- | This is the opposite of 'genericUp'.+genericDown+    :: forall n src diff+     . ( diff ~ FieldDiff (Sort (RepToTree (Rep (src (n + 1))))) (Sort (RepToTree (Rep (src n))))+       , GTransform diff (src (n + 1)) (src n)+       , Generic (src n)+       , GUndefinedFields (Rep (src n))+       )+    => src (n + 1) -> Function diff (src (n + 1)) (src n)+genericDown = gTransform @diff @_ @(src n) undefinedFields

@@ -0,0 +1,105 @@+module Data.Migration.Internal where++import Data.Generics.Product+import Data.Kind+import Lens.Micro hiding (to)+import GHC.Generics+import GHC.TypeLits++type family RepToTree (a :: Type -> Type) :: [(Symbol, Type)] where+  RepToTree (f :*: g) = RepToTree f ++ RepToTree g+  RepToTree (M1 S ('MetaSel ('Just name) _1 _2 _3) (K1 _4 t)) = '[ '(name, t) ]+  RepToTree (M1 _1 _2 f) = RepToTree f++type family (++) (xs :: [k]) (ys :: [k]) :: [k] where+  (++) '[] ys = ys+  (++) (x ': xs) ys = x ': (xs ++ ys)++type family Sort (xs :: [(Symbol, k)]) where+  Sort '[] = '[]+  Sort (x ': xs) = Insert x (Sort xs)++type family Insert (x :: (Symbol, k)) (xs :: [(Symbol, k)]) where+  Insert x '[] = x ': '[]+  Insert '(x, t) ('(y, t') ': ys) = Insert' (CmpSymbol x y) '(x, t) '(y, t') ys++type family Insert' (b :: Ordering) (x :: (Symbol, k)) (y :: (Symbol, k)) (ys :: [(Symbol, k)]) where+  Insert' 'LT x y ys = x ': (y ': ys)+  Insert' _ x y ys = y ': Insert x ys++data DiffResult+  = NoChange Symbol Type+  | Addition Symbol Type+  | Change Symbol Type Type++type family FieldDiff (a :: [(Symbol, Type)])+                      (b :: [(Symbol, Type)]) :: [DiffResult] where+  FieldDiff xs '[] = '[]+  FieldDiff '[] ('(y, v) ': ys) = 'Addition y v ': FieldDiff '[] ys++  FieldDiff ('(x, t) ': xs) ('(x, t) ': ys) = 'NoChange x t ': FieldDiff xs ys+  FieldDiff ('(x, u) ': xs) ('(x, v) ': ys) = 'Change x u v ': FieldDiff xs ys+  FieldDiff ('(x, u) ': xs) ('(y, v) ': ys) = FieldDiffImpl (CmpSymbol x y) '(x, u) '(y, v) xs ys++type family FieldDiffImpl (b :: Ordering)+                          (x :: (Symbol, Type))+                          (y :: (Symbol, Type))+                          (xs :: [(Symbol, Type)])+                          (ys :: [(Symbol, Type)]) :: [DiffResult] where+  FieldDiffImpl 'LT _ y xs ys = FieldDiff xs (y ': ys)+  FieldDiffImpl 'GT x '(y, v) xs ys = 'Addition y v ': FieldDiff (x ': xs) ys++copyField+    :: forall name t from to+     . ( HasField' name to   t+       , HasField' name from t+       )+    => from+    -> to+    -> to+copyField f t =+  t & field' @name .~ f ^. field' @name++class GTransform (ts :: [DiffResult]) (src :: Type) (dst :: Type)  where+  type Function ts src dst :: Type+  gTransform :: dst -> src -> Function ts src dst++instance (Generic dst, GUndefinedFields (Rep dst)) => GTransform '[] src dst where+  type Function '[] src dst = dst+  gTransform dst _ = dst++instance ( GTransform ts src dst+         , HasField' name src t+         , HasField' name dst t+         ) => GTransform ('NoChange name t ': ts) src dst where+  type Function ('NoChange name t ': ts) src dst  = Function ts src dst+  gTransform dst src = gTransform @ts (copyField @name src dst) src++instance ( GTransform ts src dst+         , HasField' name dst t+         ) => GTransform ('Addition name t ': ts) src dst where+  type Function ('Addition name t ': ts) src dst  = (src -> t) -> Function ts src dst+  gTransform dst src mk_t = gTransform @ts (dst & field' @name .~ mk_t src) src++instance ( GTransform ts src dst+         , HasField' name src ti+         , HasField' name dst to+         ) => GTransform ('Change name ti to ': ts) src dst where+  type Function ('Change name ti to ': ts) src dst  = (src -> ti -> to) -> Function ts src dst+  gTransform dst src mk_to = gTransform @ts (dst & field' @name .~ mk_to src (src ^. field' @name)) src++class GUndefinedFields (o :: * -> *) where+  gUndefinedFields :: o x++instance GUndefinedFields o => GUndefinedFields (M1 _3 _4 o) where+  gUndefinedFields = M1 $ gUndefinedFields++instance (GUndefinedFields o1, GUndefinedFields o2) => GUndefinedFields (o1 :*: o2) where+  gUndefinedFields = gUndefinedFields :*: gUndefinedFields++instance GUndefinedFields (K1 _1 t) where+  gUndefinedFields = K1 undefined++-- | Don't use this, it's not meant to be useful+undefinedFields :: (Generic t, GUndefinedFields (Rep t)) => t+undefinedFields = to gUndefinedFields

@@ -0,0 +1,42 @@+import Data.String+import GHC.Generics+import GHC.TypeLits+import Test.QuickCheck++import Data.Migration++data family Foo (a :: Nat)++newtype MyString = MyString { unMyString :: String }+  deriving (IsString, Show, Eq)++data instance Foo 0+  = FooV0+    { _fooId :: Int+    , _fooName :: String+    }+  deriving (Generic, Show, Eq)++instance Arbitrary (Foo 0) where+  arbitrary = do+    fooId <- arbitrary+    fooName <- arbitrary+    pure $ FooV0 fooId fooName++data instance Foo 1+  = FooV1+  { _fooId        :: Int+  , _fooName      :: MyString+  , _fooHonorific :: String+  }+  deriving (Generic, Show, Eq)++instance Transform Foo 0 where+  up   v = genericUp   v (const "esquire") (const MyString)+  down v = genericDown v (const unMyString)++prop_inverse_transform :: Foo 0 -> Bool+prop_inverse_transform v = (down $ up v) == v++main :: IO ()+main = quickCheck prop_inverse_transform