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 :: forall (name :: Symbol) t from to.
(HasField' name to t, HasField' name from t) =>
from -> to -> to
copyField from
f to
t =
  to
t forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @name forall s t a b. ASetter s t a b -> b -> s -> t
.~ from
f forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
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 -> src -> Function '[] src dst
gTransform dst
dst src
_ = 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 -> Function ('NoChange name t : ts) src dst
gTransform dst
dst src
src = forall (ts :: [DiffResult]) src dst.
GTransform ts src dst =>
dst -> src -> Function ts src dst
gTransform @ts (forall (name :: Symbol) t from to.
(HasField' name to t, HasField' name from t) =>
from -> to -> to
copyField @name src
src dst
dst) src
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 -> Function ('Addition name t : ts) src dst
gTransform dst
dst src
src src -> t
mk_t = forall (ts :: [DiffResult]) src dst.
GTransform ts src dst =>
dst -> src -> Function ts src dst
gTransform @ts (dst
dst forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @name forall s t a b. ASetter s t a b -> b -> s -> t
.~ src -> t
mk_t src
src) 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 -> Function ('Change name ti to : ts) src dst
gTransform dst
dst src
src src -> ti -> to
mk_to = forall (ts :: [DiffResult]) src dst.
GTransform ts src dst =>
dst -> src -> Function ts src dst
gTransform @ts (dst
dst forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @name forall s t a b. ASetter s t a b -> b -> s -> t
.~ src -> ti -> to
mk_to src
src (src
src forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @name)) src
src

class GUndefinedFields (o :: Type -> Type) where
  gUndefinedFields :: o x

instance GUndefinedFields o => GUndefinedFields (M1 _3 _4 o) where
  gUndefinedFields :: forall x. M1 _3 _4 o x
gUndefinedFields = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) x. GUndefinedFields o => o x
gUndefinedFields

instance (GUndefinedFields o1, GUndefinedFields o2) => GUndefinedFields (o1 :*: o2) where
  gUndefinedFields :: forall x. (:*:) o1 o2 x
gUndefinedFields = forall (o :: * -> *) x. GUndefinedFields o => o x
gUndefinedFields forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (o :: * -> *) x. GUndefinedFields o => o x
gUndefinedFields

instance GUndefinedFields (K1 _1 t) where
  gUndefinedFields :: forall x. K1 _1 t x
gUndefinedFields = forall k i c (p :: k). c -> K1 i c p
K1 forall a. HasCallStack => a
undefined

-- | Don't use this, it's not meant to be useful
undefinedFields :: (Generic t, GUndefinedFields (Rep t)) => t
undefinedFields :: forall t. (Generic t, GUndefinedFields (Rep t)) => t
undefinedFields = forall a x. Generic a => Rep a x -> a
to forall (o :: * -> *) x. GUndefinedFields o => o x
gUndefinedFields