module Generics.SOP.Lens.Named (
    -- * Monomorphic total lens, abstracted over target
    LensName
  , NamedLens(..)
  , get
  , modify
  , set
    -- * Generic construction
  , gnamedLenses
  ) where

import Generics.SOP
import Generics.SOP.Lens (GLens)
import qualified Generics.SOP.Lens as GLens

{-------------------------------------------------------------------------------
  Wrapper around Data.Label
-------------------------------------------------------------------------------}

type LensName = String

-- | Total abstract lens
data NamedLens a ctxt = forall b. ctxt b => NamedLens {
    ()
unNamedLens :: GLens I I a b
  }

instance Show (NamedLens a ctxt) where
  show :: NamedLens a ctxt -> String
show NamedLens a ctxt
_ = String
"<<NamedLens>"

get :: NamedLens a ctxt -> (forall b. ctxt b => b -> c) -> a -> c
get :: forall a (ctxt :: * -> Constraint) c.
NamedLens a ctxt -> (forall b. ctxt b => b -> c) -> a -> c
get (NamedLens GLens I I a b
l) forall b. ctxt b => b -> c
k = forall b. ctxt b => b -> c
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> *) (w :: * -> *) a b. GLens r w a b -> a -> r b
GLens.get GLens I I a b
l

modify :: NamedLens a ctxt -> (forall b. ctxt b => b -> b) -> a -> a
modify :: forall a (ctxt :: * -> Constraint).
NamedLens a ctxt -> (forall b. ctxt b => b -> b) -> a -> a
modify (NamedLens GLens I I a b
l) forall b. ctxt b => b -> b
f = forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> *) (w :: * -> *) a b.
GLens r w a b -> (b -> w b) -> a -> w a
GLens.modify GLens I I a b
l (forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ctxt b => b -> b
f)

set :: NamedLens a ctxt -> (forall b. ctxt b => b) -> a -> a
set :: forall a (ctxt :: * -> Constraint).
NamedLens a ctxt -> (forall b. ctxt b => b) -> a -> a
set (NamedLens GLens I I a b
l) forall b. ctxt b => b
b = forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) (r :: * -> *) a b.
Monad w =>
GLens r w a b -> b -> a -> w a
GLens.set GLens I I a b
l forall b. ctxt b => b
b

{-------------------------------------------------------------------------------
  Construct named lenses
-------------------------------------------------------------------------------}

-- | Construct named lenses for a record type
--
-- NOTE: This will throw a runtime error for non-record types
gnamedLenses :: forall a ctxt xs.
     (HasDatatypeInfo a, Code a ~ '[xs], All ctxt xs)
  => (DatatypeName -> ConstructorName -> LensName)
  -> [(String, NamedLens a ctxt)]
gnamedLenses :: forall a (ctxt :: * -> Constraint) (xs :: [*]).
(HasDatatypeInfo a, Code a ~ '[xs], All ctxt xs) =>
(String -> ShowS) -> [(String, NamedLens a ctxt)]
gnamedLenses String -> ShowS
mkName = case forall {k} (xs :: [k]). SListI xs => SList xs
sList :: SList (Code a) of
    SList (Code a)
SCons -> forall a b. [a] -> [b] -> [(a, b)]
zip (forall (xs :: [*]).
(String -> ShowS) -> DatatypeInfo '[xs] -> [String]
fieldNames String -> ShowS
mkName (forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
pa))
                 (forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy ctxt
pc (forall k a (b :: k). a -> K a b
K forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ctxt :: * -> Constraint) b.
ctxt b =>
GLens I I a b -> NamedLens a ctxt
NamedLens) NP (GLens I I a) xs
totalLenses)
  where
    totalLenses :: NP (GLens I I a) xs
    totalLenses :: NP (GLens I I a) xs
totalLenses = forall (r :: * -> *) (w :: * -> *) a (xs :: [*]).
(Generic a, Code a ~ '[xs], Monad r, Monad w) =>
NP (GLens r w a) xs
GLens.glenses

    pa :: Proxy a
    pa :: Proxy a
pa = forall {k} (t :: k). Proxy t
Proxy

    pc :: Proxy ctxt
    pc :: Proxy ctxt
pc = forall {k} (t :: k). Proxy t
Proxy

fieldNames :: (DatatypeName -> FieldName -> LensName)
           -> DatatypeInfo '[xs] -> [String]
fieldNames :: forall (xs :: [*]).
(String -> ShowS) -> DatatypeInfo '[xs] -> [String]
fieldNames String -> ShowS
mkName DatatypeInfo '[xs]
d =
  forall (xs :: [*]). ShowS -> ConstructorInfo xs -> [String]
fieldNames' (String -> ShowS
mkName (forall (xss :: [[*]]). DatatypeInfo xss -> String
datatypeName DatatypeInfo '[xs]
d)) (forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo '[xs]
d))

fieldNames' :: (FieldName -> LensName) -> ConstructorInfo xs -> [String]
fieldNames' :: forall (xs :: [*]). ShowS -> ConstructorInfo xs -> [String]
fieldNames' ShowS
_      (Constructor String
_)    = forall a. HasCallStack => String -> a
error String
"not a record type"
fieldNames' ShowS
_      (Infix String
_ Associativity
_ Int
_)      = forall a. HasCallStack => String -> a
error String
"not a record type"
fieldNames' ShowS
mkName (Record      String
_ NP FieldInfo xs
fs) = forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA forall a. FieldInfo a -> K String a
aux NP FieldInfo xs
fs
  where
    aux :: FieldInfo a -> K String a
    aux :: forall a. FieldInfo a -> K String a
aux (FieldInfo String
n) = forall k a (b :: k). a -> K a b
K (ShowS
mkName String
n)