Test the migrations

test/MyLibTest.hs

@@ -1,4 +1,13 @@
 module Main (main) where
 
+import Test.Tasty
+
+import qualified Test.Database.Migrations as Database.Migrations
+
+tests :: TestTree
+tests = testGroup "buuka"
+  [ Database.Migrations.tests
+  ]
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented."
+main = defaultMain tests

test/Test/Database/Migrations.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+module Test.Database.Migrations where
+
+import Hedgehog
+import qualified Hedgehog.Corpus as Corpus
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import qualified Data.Text as T
+
+import Data.Aeson
+import Data.Proxy
+       (Proxy(..))
+import GHC.Generics
+       (Generic)
+
+import Database.Migrations
+
+newtype Foo_0 = Foo_0 { name :: String }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+data Foo_1 = Foo_1 { name :: String, age :: Int }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+data Foo = Foo { name :: T.Text, age :: Int }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+instance SafeJSON Foo_0 where
+  type Version Foo_0 = 0
+  kind = Base
+
+instance SafeJSON Foo_1 where
+  type Version Foo_1 = 1
+  kind = Extends Proxy
+
+instance SafeJSON Foo where
+  type Version Foo = 1
+  kind = Extends Proxy
+
+instance Migrate Foo_1 where
+  type MigrateFrom Foo_1 = Foo_0
+  migrate Foo_0{..} = Just Foo_1{name=name, age=0}
+
+instance Migrate Foo where
+  type MigrateFrom Foo = Foo_1
+  migrate Foo_1{..} = Just Foo{name=T.pack name, age=age}
+
+genFoo :: Gen Foo
+genFoo = Foo <$> Gen.element Corpus.simpsons <*> Gen.integral (Range.linear 0 100)
+
+genFoo_1 :: Gen Foo_1
+genFoo_1 = Foo_1 <$> Gen.element Corpus.simpsons <*> Gen.integral (Range.linear 0 100)
+
+genFoo_0 :: Gen Foo_0
+genFoo_0 = Foo_0 <$> Gen.element Corpus.simpsons
+
+prop_roundtrip_same_version :: Property
+prop_roundtrip_same_version = property $ do
+  x <- forAll genFoo
+  tripping x toVersioned fromVersioned
+
+prop_roundtrip_one_migration :: Property
+prop_roundtrip_one_migration = property $ do
+  x <- forAll genFoo_1
+  fromVersioned (toVersioned x) === maybe (Error "No migrations") Success (migrate @Foo x)
+
+prop_roundtrip_multiple_migration :: Property
+prop_roundtrip_multiple_migration = property $ do
+  x <- forAll genFoo_0
+  fromVersioned (toVersioned x) === maybe (Error "No migrations") Success (migrate x >>= migrate @Foo)
+
+tests :: TestTree
+tests = testGroup "Database.Migrations"
+  [ testProperty "Roundtrip with same version" prop_roundtrip_same_version
+  , testProperty "Roundtrip with one migration" prop_roundtrip_one_migration
+  , testProperty "Roundtrip with multiple migrations" prop_roundtrip_multiple_migration
+  ]