{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module      : Database.Migrations
Description : Semiautomatic migrations for json values
Copyright   : (c) Mats Rauhala, 2020
License     : BSD-3-Clause
Maintainer  : mats.rauhala@iki.fi
Stability   : experimental
Portability : POSIX

The idea is taken from the safecopy module.
-}
module Database.Migrations where

import Data.Aeson

import Data.Proxy
import GHC.Generics
       (Generic)
import GHC.TypeLits

data Versioned
  = Versioned { version :: !Integer, content :: !Value }
  deriving stock (Show, Generic, Eq)
  deriving anyclass (ToJSON, FromJSON)

data Kind a where
  Base :: Kind a
  Extends :: (SafeJSON (MigrateFrom a), KnownNat (Version (MigrateFrom a)), Migrate a) => Proxy (MigrateFrom a) -> Kind a

class FromJSON a => SafeJSON a where
  type Version a :: Nat

  kind :: Kind a
  kind = Base

data Extending (a :: Nat) x

class Migrate a where
  type MigrateFrom a :: *
  migrate :: MigrateFrom a -> Maybe a

type Migratable a = (SafeJSON a, KnownNat (Version a))

-- | Convert any json value into a versioned version
toVersioned :: forall a. (ToJSON a, KnownNat (Version a), SafeJSON a) => a -> Versioned
toVersioned x =
  Versioned{ version = natVal @(Version a) Proxy
           , content = toJSON x
           }

eitherFromVersioned :: forall a. Migratable a => Versioned -> Either String a
eitherFromVersioned x =
  case fromVersioned x of
       Success s -> Right s
       Error e -> Left e

-- | Convert a json value into result type 'a' doing migrations if required
fromVersioned :: forall a. Migratable a => Versioned -> Result a
fromVersioned = worker (kind @a)
  where
    kindFromProxy :: SafeJSON x => Proxy x -> Kind x
    kindFromProxy _ = kind
    worker :: forall b. Migratable b => Kind b -> Versioned -> Result b
    worker thisKind Versioned{..}
      -- The versions match
      | version == natVal @(Version b) Proxy = fromJSON content
      -- Migrations required
      | otherwise =
        case thisKind of
             Base -> Error "Version not found"
             Extends x -> do
               previous <- worker (kindFromProxy x) (Versioned version content)
               maybe (Error "Migration not found") Success $ migrate previous