{- |
The generic derivation is split into 3 classes, dealing with different layers of
a Haskell data type: datatype, constructor and selector. At each point, we
gather up information about the type and push on. Strengthening occurs at
selectors. If a strengthening fails, the gathered information is pushed into an
error that wraps the original error.
-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}

module Strongweak.Generic.Strengthen where

import Strongweak.Strengthen
import Data.Validation
import Data.List.NonEmpty

import GHC.Generics

strengthenGeneric
    :: (Generic w, Generic s, GStrengthenD (Rep w) (Rep s))
    => w -> Validation (NonEmpty StrengthenError) s
strengthenGeneric :: forall w s.
(Generic w, Generic s, GStrengthenD (Rep w) (Rep s)) =>
w -> Validation (NonEmpty StrengthenError) s
strengthenGeneric = (Rep s Any -> s)
-> Validation (NonEmpty StrengthenError) (Rep s Any)
-> Validation (NonEmpty StrengthenError) s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep s Any -> s
forall a x. Generic a => Rep a x -> a
to (Validation (NonEmpty StrengthenError) (Rep s Any)
 -> Validation (NonEmpty StrengthenError) s)
-> (w -> Validation (NonEmpty StrengthenError) (Rep s Any))
-> w
-> Validation (NonEmpty StrengthenError) s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep w Any -> Validation (NonEmpty StrengthenError) (Rep s Any)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenD w s =>
w p -> Validation (NonEmpty StrengthenError) (s p)
gstrengthenD (Rep w Any -> Validation (NonEmpty StrengthenError) (Rep s Any))
-> (w -> Rep w Any)
-> w
-> Validation (NonEmpty StrengthenError) (Rep s Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Rep w Any
forall a x. Generic a => a -> Rep a x
from

class GStrengthenD w s where
    gstrengthenD :: w p -> Validation (NonEmpty StrengthenError) (s p)

instance (GStrengthenC w s, Datatype dw, Datatype ds) => GStrengthenD (D1 dw w) (D1 ds s) where
    gstrengthenD :: forall (p :: k).
D1 dw w p -> Validation (NonEmpty StrengthenError) (D1 ds s p)
gstrengthenD = (s p -> D1 ds s p)
-> Validation (NonEmpty StrengthenError) (s p)
-> Validation (NonEmpty StrengthenError) (D1 ds s p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s p -> D1 ds s p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Validation (NonEmpty StrengthenError) (s p)
 -> Validation (NonEmpty StrengthenError) (D1 ds s p))
-> (D1 dw w p -> Validation (NonEmpty StrengthenError) (s p))
-> D1 dw w p
-> Validation (NonEmpty StrengthenError) (D1 ds s p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> String -> w p -> Validation (NonEmpty StrengthenError) (s p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenC w s =>
String
-> String -> w p -> Validation (NonEmpty StrengthenError) (s p)
gstrengthenC (forall {k} (d :: k). Datatype d => String
forall (d :: Meta). Datatype d => String
datatypeName' @dw) (forall {k} (d :: k). Datatype d => String
forall (d :: Meta). Datatype d => String
datatypeName' @ds) (w p -> Validation (NonEmpty StrengthenError) (s p))
-> (D1 dw w p -> w p)
-> D1 dw w p
-> Validation (NonEmpty StrengthenError) (s p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 dw w p -> w p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

class GStrengthenC w s where
    gstrengthenC :: String -> String -> w p -> Validation (NonEmpty StrengthenError) (s p)

-- | Nothing to do for empty datatypes.
instance GStrengthenC V1 V1 where
    gstrengthenC :: forall (p :: k).
String
-> String -> V1 p -> Validation (NonEmpty StrengthenError) (V1 p)
gstrengthenC String
_ String
_ = V1 p -> Validation (NonEmpty StrengthenError) (V1 p)
forall err a. a -> Validation err a
Success

instance (GStrengthenS w s, Constructor cw, Constructor cs) => GStrengthenC (C1 cw w) (C1 cs s) where
    gstrengthenC :: forall (p :: k).
String
-> String
-> C1 cw w p
-> Validation (NonEmpty StrengthenError) (C1 cs s p)
gstrengthenC String
dw String
ds = (s p -> C1 cs s p)
-> Validation (NonEmpty StrengthenError) (s p)
-> Validation (NonEmpty StrengthenError) (C1 cs s p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s p -> C1 cs s p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Validation (NonEmpty StrengthenError) (s p)
 -> Validation (NonEmpty StrengthenError) (C1 cs s p))
-> (C1 cw w p -> Validation (NonEmpty StrengthenError) (s p))
-> C1 cw w p
-> Validation (NonEmpty StrengthenError) (C1 cs s p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> String
-> String
-> String
-> w p
-> Validation (NonEmpty StrengthenError) (s p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> w p
-> Validation (NonEmpty StrengthenError) (s p)
gstrengthenS String
dw String
ds (forall {k} (c :: k). Constructor c => String
forall (c :: Meta). Constructor c => String
conName' @cw) (forall {k} (c :: k). Constructor c => String
forall (c :: Meta). Constructor c => String
conName' @cs) (w p -> Validation (NonEmpty StrengthenError) (s p))
-> (C1 cw w p -> w p)
-> C1 cw w p
-> Validation (NonEmpty StrengthenError) (s p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 cw w p -> w p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

-- | Strengthen sum types by strengthening left or right.
instance (GStrengthenC lw ls, GStrengthenC rw rs) => GStrengthenC (lw :+: rw) (ls :+: rs) where
    gstrengthenC :: forall (p :: k).
String
-> String
-> (:+:) lw rw p
-> Validation (NonEmpty StrengthenError) ((:+:) ls rs p)
gstrengthenC String
dw String
ds = \case L1 lw p
l -> ls p -> (:+:) ls rs p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (ls p -> (:+:) ls rs p)
-> Validation (NonEmpty StrengthenError) (ls p)
-> Validation (NonEmpty StrengthenError) ((:+:) ls rs p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> String -> lw p -> Validation (NonEmpty StrengthenError) (ls p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenC w s =>
String
-> String -> w p -> Validation (NonEmpty StrengthenError) (s p)
gstrengthenC String
dw String
ds lw p
l
                               R1 rw p
r -> rs p -> (:+:) ls rs p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (rs p -> (:+:) ls rs p)
-> Validation (NonEmpty StrengthenError) (rs p)
-> Validation (NonEmpty StrengthenError) ((:+:) ls rs p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> String -> rw p -> Validation (NonEmpty StrengthenError) (rs p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenC w s =>
String
-> String -> w p -> Validation (NonEmpty StrengthenError) (s p)
gstrengthenC String
dw String
ds rw p
r

class GStrengthenS w s where
    gstrengthenS :: String -> String -> String -> String -> w p -> Validation (NonEmpty StrengthenError) (s p)

-- | Nothing to do for empty constructors.
instance GStrengthenS U1 U1 where
    gstrengthenS :: forall (p :: k).
String
-> String
-> String
-> String
-> U1 p
-> Validation (NonEmpty StrengthenError) (U1 p)
gstrengthenS String
_ String
_ String
_ String
_ = U1 p -> Validation (NonEmpty StrengthenError) (U1 p)
forall err a. a -> Validation err a
Success

-- | Special case: if source and target types are equal, copy the value through.
instance GStrengthenS (S1 mw (Rec0 w)) (S1 ms (Rec0 w)) where
    gstrengthenS :: forall (p :: k).
String
-> String
-> String
-> String
-> S1 mw (Rec0 w) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p)
gstrengthenS String
_ String
_ String
_ String
_ = S1 ms (Rec0 w) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p)
forall err a. a -> Validation err a
Success (S1 ms (Rec0 w) p
 -> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p))
-> (S1 mw (Rec0 w) p -> S1 ms (Rec0 w) p)
-> S1 mw (Rec0 w) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec0 w p -> S1 ms (Rec0 w) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 w p -> S1 ms (Rec0 w) p)
-> (S1 mw (Rec0 w) p -> Rec0 w p)
-> S1 mw (Rec0 w) p
-> S1 ms (Rec0 w) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 mw (Rec0 w) p -> Rec0 w p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

-- | Strengthen a field using the existing 'Strengthen' instance.
instance {-# OVERLAPS #-} (Strengthen w s, Selector mw, Selector ms) => GStrengthenS (S1 mw (Rec0 w)) (S1 ms (Rec0 s)) where
    gstrengthenS :: forall (p :: k).
String
-> String
-> String
-> String
-> S1 mw (Rec0 w) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
gstrengthenS String
dw String
ds String
cw String
cs (M1 (K1 w
w)) =
        case w -> Validation (NonEmpty StrengthenError) s
forall w s.
Strengthen w s =>
w -> Validation (NonEmpty StrengthenError) s
strengthen w
w of
          Failure (StrengthenError
e :| [StrengthenError]
es) -> NonEmpty StrengthenError
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall err a. err -> Validation err a
Failure (NonEmpty StrengthenError
 -> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p))
-> NonEmpty StrengthenError
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall a b. (a -> b) -> a -> b
$ String
-> String
-> String
-> String
-> String
-> String
-> StrengthenError
-> StrengthenError
StrengthenErrorField String
dw String
ds String
cw String
cs (forall {k} (s :: k). Selector s => String
forall (s :: Meta). Selector s => String
selName' @mw) (forall {k} (s :: k). Selector s => String
forall (s :: Meta). Selector s => String
selName' @ms) StrengthenError
e StrengthenError -> [StrengthenError] -> NonEmpty StrengthenError
forall a. a -> [a] -> NonEmpty a
:| [StrengthenError]
es
          Success s
s   -> S1 ms (Rec0 s) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall err a. a -> Validation err a
Success (S1 ms (Rec0 s) p
 -> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p))
-> S1 ms (Rec0 s) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall a b. (a -> b) -> a -> b
$ Rec0 s p -> S1 ms (Rec0 s) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 s p -> S1 ms (Rec0 s) p) -> Rec0 s p -> S1 ms (Rec0 s) p
forall a b. (a -> b) -> a -> b
$ s -> Rec0 s p
forall k i c (p :: k). c -> K1 i c p
K1 s
s

-- | Strengthen product types by strengthening left, then right.
instance (GStrengthenS lw ls, GStrengthenS rw rs) => GStrengthenS (lw :*: rw) (ls :*: rs) where
    gstrengthenS :: forall (p :: k).
String
-> String
-> String
-> String
-> (:*:) lw rw p
-> Validation (NonEmpty StrengthenError) ((:*:) ls rs p)
gstrengthenS String
dw String
ds String
cw String
cs (lw p
l :*: rw p
r) = do
        ls p
l' <- String
-> String
-> String
-> String
-> lw p
-> Validation (NonEmpty StrengthenError) (ls p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> w p
-> Validation (NonEmpty StrengthenError) (s p)
gstrengthenS String
dw String
ds String
cw String
cs lw p
l
        rs p
r' <- String
-> String
-> String
-> String
-> rw p
-> Validation (NonEmpty StrengthenError) (rs p)
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> w p
-> Validation (NonEmpty StrengthenError) (s p)
gstrengthenS String
dw String
ds String
cw String
cs rw p
r
        return $ ls p
l' ls p -> rs p -> (:*:) ls rs p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: rs p
r'

--------------------------------------------------------------------------------

-- | 'conName' without the value (only used as a proxy). Lets us push our
--   'undefined's into one place.
conName' :: forall c. Constructor c => String
conName' :: forall {k} (c :: k). Constructor c => String
conName' = forall (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
Constructor c =>
t c f a -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @c Any c Any Any
forall a. HasCallStack => a
undefined

-- | 'datatypeName' without the value (only used as a proxy). Lets us push our
--   'undefined's into one place.
datatypeName' :: forall d. Datatype d => String
datatypeName' :: forall {k} (d :: k). Datatype d => String
datatypeName' = forall (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
Datatype d =>
t d f a -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName @d Any d Any Any
forall a. HasCallStack => a
undefined

-- | 'datatypeName' without the value (only used as a proxy). Lets us push our
--   'undefined's into one place.
selName' :: forall s. Selector s => String
selName' :: forall {k} (s :: k). Selector s => String
selName' = forall (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
Selector s =>
t s f a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @s Any s Any Any
forall a. HasCallStack => a
undefined