{- | Strengthening for generic data types.

The generic derivation is split into 3 classes, each dealing with a different
layer of a generic Haskell data type: datatype (D), constructor (C) and selector
(S). 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 #-}

module Strongweak.Generic.Strengthen where

import Strongweak.Strengthen
import Data.Either.Validation
import Data.List.NonEmpty
import GHC.Generics

import Numeric.Natural
import Control.Applicative ( liftA2 )

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 e a. a -> Validation e 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
. (Natural, Validation (NonEmpty StrengthenError) (s p))
-> Validation (NonEmpty StrengthenError) (s p)
forall a b. (a, b) -> b
snd ((Natural, Validation (NonEmpty StrengthenError) (s p))
 -> Validation (NonEmpty StrengthenError) (s p))
-> (C1 cw w p
    -> (Natural, Validation (NonEmpty StrengthenError) (s p)))
-> C1 cw w p
-> Validation (NonEmpty StrengthenError) (s p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> String
-> String
-> String
-> Natural
-> w p
-> (Natural, Validation (NonEmpty StrengthenError) (s p))
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> Natural
-> w p
-> (Natural, 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) Natural
0 (w p -> (Natural, Validation (NonEmpty StrengthenError) (s p)))
-> (C1 cw w p -> w p)
-> C1 cw w p
-> (Natural, 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 -> Natural -> w p -> (Natural, Validation (NonEmpty StrengthenError) (s p))

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

-- | 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
-> Natural
-> S1 mw (Rec0 w) p
-> (Natural,
    Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p))
gstrengthenS String
_ String
_ String
_ String
_ Natural
n S1 mw (Rec0 w) p
x = (Natural
n, S1 ms (Rec0 w) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 w) p)
forall e a. a -> Validation e a
Success (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 (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 S1 mw (Rec0 w) p
x)))

-- | Strengthen a field using the existing 'Strengthen' instance.
--
-- On strengthen failure, the errors are annotated with all the datatype
-- information we've hoarded. The upshot is that if you strengthen a type with
-- lots of types inside it, all with generically-derived 'Strengthen' instances,
-- you'll get a precise zoom-in of exactly where each error occurred.
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
-> Natural
-> S1 mw (Rec0 w) p
-> (Natural,
    Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p))
gstrengthenS String
dw String
ds String
cw String
cs Natural
n (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 NonEmpty StrengthenError
es ->
            let fw :: Maybe String
fw = forall {k} (s :: k). Selector s => Maybe String
forall (s :: Meta). Selector s => Maybe String
selName'' @mw
                fs :: Maybe String
fs = forall {k} (s :: k). Selector s => Maybe String
forall (s :: Meta). Selector s => Maybe String
selName'' @ms
                e :: StrengthenError
e  = String
-> String
-> String
-> String
-> Natural
-> Maybe String
-> Natural
-> Maybe String
-> NonEmpty StrengthenError
-> StrengthenError
StrengthenErrorField String
dw String
ds String
cw String
cs Natural
n Maybe String
fw Natural
n Maybe String
fs NonEmpty StrengthenError
es
            in  (Natural
n, NonEmpty StrengthenError
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall e a. e -> Validation e 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
$ StrengthenError
e StrengthenError -> [StrengthenError] -> NonEmpty StrengthenError
forall a. a -> [a] -> NonEmpty a
:| [])
          Success s
s   -> (Natural
n, S1 ms (Rec0 s) p
-> Validation (NonEmpty StrengthenError) (S1 ms (Rec0 s) p)
forall e a. a -> Validation e 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)

-- | Get the record name for a selector if present.
--
-- On the type level, a 'Maybe Symbol' is stored for record names. But the
-- reification is done using @fromMaybe ""@. So we have to inspect the resulting
-- string to determine whether the field uses record syntax or not. (Silly.)
selName'' :: forall s. Selector s => Maybe String
selName'' :: forall {k} (s :: k). Selector s => Maybe String
selName'' = case forall (s :: k). Selector s => String
forall {k} (s :: k). Selector s => String
selName' @s of String
"" -> Maybe String
forall a. Maybe a
Nothing
                                String
s  -> String -> Maybe String
forall a. a -> Maybe a
Just String
s

-- | Strengthen product types by strengthening left and right.
--
-- This is ordered (left then right), but only to pass the index along.
instance (GStrengthenS lw ls, GStrengthenS rw rs) => GStrengthenS (lw :*: rw) (ls :*: rs) where
    gstrengthenS :: forall (p :: k).
String
-> String
-> String
-> String
-> Natural
-> (:*:) lw rw p
-> (Natural, Validation (NonEmpty StrengthenError) ((:*:) ls rs p))
gstrengthenS String
dw String
ds String
cw String
cs Natural
n (lw p
l :*: rw p
r) = (Natural
n'', (ls p -> rs p -> (:*:) ls rs p)
-> Validation (NonEmpty StrengthenError) (ls p)
-> Validation (NonEmpty StrengthenError) (rs p)
-> Validation (NonEmpty StrengthenError) ((:*:) ls rs p)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ls p -> rs p -> (:*:) ls rs p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) Validation (NonEmpty StrengthenError) (ls p)
l' Validation (NonEmpty StrengthenError) (rs p)
r')
      where
        (Natural
n',  Validation (NonEmpty StrengthenError) (ls p)
l') = String
-> String
-> String
-> String
-> Natural
-> lw p
-> (Natural, Validation (NonEmpty StrengthenError) (ls p))
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> Natural
-> w p
-> (Natural, Validation (NonEmpty StrengthenError) (s p))
gstrengthenS String
dw String
ds String
cw String
cs Natural
n      lw p
l
        (Natural
n'', Validation (NonEmpty StrengthenError) (rs p)
r') = String
-> String
-> String
-> String
-> Natural
-> rw p
-> (Natural, Validation (NonEmpty StrengthenError) (rs p))
forall {k} (w :: k -> *) (s :: k -> *) (p :: k).
GStrengthenS w s =>
String
-> String
-> String
-> String
-> Natural
-> w p
-> (Natural, Validation (NonEmpty StrengthenError) (s p))
gstrengthenS String
dw String
ds String
cw String
cs (Natural
n'Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1) rw 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

-- | 'selName' 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