module Generics.SOP.Lens.Computed (
    -- * Abstract lenses
    AbstractLens(..)
  , abstractId
  , afterGLens
    -- * Getters and setters
  , get
  , set
  , modify
  , getM
  , setM
  , modifyM
    -- * Computing lenses
  , Path
  , CLens
  , lens
    -- * Manually constructing lenses
  , emptyPathOnly
    -- * Configuration
  , LensOptions(..)
  , defaultLensOptions
  ) where

import Prelude hiding (id, (.))

import Control.Category
import Control.Monad
import Data.Functor.Identity
import Data.Maybe (catMaybes)

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

import qualified Generics.SOP.Lens as GLens

{-------------------------------------------------------------------------------
  Abstract lenses
-------------------------------------------------------------------------------}

-- | An abstract lens qualifies existentially over the target type of the lens
--
-- Sadly, abstract lenses do not form a category, so we provide special
-- identity and composition functions.
data AbstractLens r w c a =
  forall x. c x => AbstractLens (GLens r w a x)

-- | Identity abstract lens
abstractId :: (Monad r, c a) => AbstractLens r w c a
abstractId :: forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId = forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a x.
c x =>
GLens r w a x -> AbstractLens r w c a
AbstractLens forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Compose with a pointwise lens on the right
afterGLens ::
     Monad r
  => AbstractLens r w c   a -- ^ @a -> x@
  -> GLens        r w   b a -- ^ @b -> a@
  -> AbstractLens r w c b   -- ^ @b -> x@
afterGLens :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
afterGLens (AbstractLens GLens r w a x
l) GLens r w b a
l' = forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a x.
c x =>
GLens r w a x -> AbstractLens r w c a
AbstractLens (GLens r w a x
l forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GLens r w b a
l')

{-------------------------------------------------------------------------------
  Getters and setters (mostly just for convenience)
-------------------------------------------------------------------------------}

-- | Getter for computed lenses
--
-- > get l == runIdentity . getM l . Identity
get :: AbstractLens r w c a -> (forall x. c x => (a -> r x) -> b) -> b
get :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> b) -> b
get AbstractLens r w c a
l forall x. c x => (a -> r x) -> b
f = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a
       (m :: * -> *) b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> m b) -> m b
getM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall x. c x => (a -> r x) -> b
f)

-- | Setter for computed lenses
--
-- > set l == runIdentity . setM l . Identity
set :: Monad w => AbstractLens r w c a -> (forall x. c x => x) -> a -> w a
set :: forall (w :: * -> *) (r :: * -> *) (c :: * -> Constraint) a.
Monad w =>
AbstractLens r w c a -> (forall x. c x => x) -> a -> w a
set AbstractLens r w c a
l forall x. c x => x
x = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (w :: * -> *) (m :: * -> *) (r :: * -> *)
       (c :: * -> Constraint) a.
(Monad w, Functor m) =>
AbstractLens r w c a -> (forall x. c x => m x) -> m (a -> w a)
setM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall x. c x => x
x)

-- | Modifier for computed lenses
modify :: AbstractLens r w c a -> (forall x. c x => x -> w x) -> a -> w a
modify :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a.
AbstractLens r w c a -> (forall x. c x => x -> w x) -> a -> w a
modify AbstractLens r w c a
l forall x. c x => x -> w x
f = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (r :: * -> *) (w :: * -> *)
       (c :: * -> Constraint) a.
Functor m =>
AbstractLens r w c a
-> (forall x. c x => m (x -> w x)) -> m (a -> w a)
modifyM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall x. c x => x -> w x
f)

-- | Getter with possibility for "compile time" failure
getM :: AbstractLens r w c a
     -> (forall x. c x => (a -> r x) -> m b)
     -> m b
getM :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a
       (m :: * -> *) b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> m b) -> m b
getM (AbstractLens GLens r w a x
l) forall x. c x => (a -> r x) -> m b
k = forall x. c x => (a -> r x) -> m b
k (forall (r :: * -> *) (w :: * -> *) a b. GLens r w a b -> a -> r b
GLens.get GLens r w a x
l)

-- | Setter with possibility for "compile time" failure
setM ::
     (Monad w, Functor m)
  => AbstractLens r w c a
  -> (forall x. c x => m x)
  -> m (a -> w a)
setM :: forall (w :: * -> *) (m :: * -> *) (r :: * -> *)
       (c :: * -> Constraint) a.
(Monad w, Functor m) =>
AbstractLens r w c a -> (forall x. c x => m x) -> m (a -> w a)
setM (AbstractLens GLens r w a x
l) forall x. c x => m x
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (w :: * -> *) (r :: * -> *) a b.
Monad w =>
GLens r w a b -> b -> a -> w a
GLens.set GLens r w a x
l) forall x. c x => m x
x

-- | Modifier with possibility for "compile time" failure
modifyM ::
     Functor m
  => AbstractLens r w c a
  -> (forall x. c x => m (x -> w x))
  -> m (a -> w a)
modifyM :: forall (m :: * -> *) (r :: * -> *) (w :: * -> *)
       (c :: * -> Constraint) a.
Functor m =>
AbstractLens r w c a
-> (forall x. c x => m (x -> w x)) -> m (a -> w a)
modifyM (AbstractLens GLens r w a x
l) forall x. c x => m (x -> w x)
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (r :: * -> *) (w :: * -> *) a b.
GLens r w a b -> (b -> w b) -> a -> w a
GLens.modify GLens r w a x
l) forall x. c x => m (x -> w x)
f

{-------------------------------------------------------------------------------
  Paths
-------------------------------------------------------------------------------}

-- | A path is a series of field names. For instance, given
--
-- > data T1 = T1 { a :: Int, b :: Int } deriving Generic
-- > data T2 = T2 { c :: T1,  d :: Int } deriving Generic
--
-- valid paths on T2 are
--
-- > []
-- > ["c"]
-- > ["d"]
-- > ["c", "a"]
-- > ["c", "b"]
type Path = [String]

{-------------------------------------------------------------------------------
  Top-level generic function
-------------------------------------------------------------------------------}

-- | Compute a lens for a given type and path
--
-- The @Either@ is used to indicate "compile time" failure of the computation
-- of the lens (for instance, when this path is invalid for this data type).
--
-- Some lenses may of course be themselves effectful, depending on the category.
-- However, the lenses returned by the generic computation are pure and total
-- (as is evident from the type of glens).
class CLens r w c a where
  lens :: LensOptions -> Path -> Either String (AbstractLens r w c a)

  default lens :: ( HasDatatypeInfo a
                  , Monad r
                  , Monad w
                  , c a
                  , Code a ~ '[xs]
                  , All (CLens r w c) xs
                  )
               => LensOptions -> Path -> Either String (AbstractLens r w c a)
  lens = forall (r :: * -> *) (w :: * -> *) a (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, HasDatatypeInfo a, c a, Code a ~ '[xs],
 All (CLens r w c) xs) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
glens

{-------------------------------------------------------------------------------
  Instances

  We don't provide any instances here, because applications might want to
  implement special kinds of semantics for certain paths for types that we
  normally cannot "look into".
-------------------------------------------------------------------------------}

-- | A lens for abstract types (supports empty paths only)
--
-- Useful for defining CLens instances for types such as Int, Bool,
-- Text, etc.
--
-- > instance CLens c Int where lens = emptyPathOnly
emptyPathOnly ::
     (Monad r, c a)
  => LensOptions -> Path -> Either String (AbstractLens r w c a)
emptyPathOnly :: forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
emptyPathOnly LensOptions
_ [] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId
emptyPathOnly LensOptions
_ Path
_  = forall a b. a -> Either a b
Left FieldName
"Trying to look inside abstract type"

{-------------------------------------------------------------------------------
  Lens options
-------------------------------------------------------------------------------}

data LensOptions = LensOptions {
    -- | Match a selector against a path component
    LensOptions -> FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch :: DatatypeName -> FieldName -> String -> Bool
  }

-- | Default match just compares field names
defaultLensOptions :: LensOptions
defaultLensOptions :: LensOptions
defaultLensOptions = LensOptions {
    lensOptionsMatch :: FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch = forall a b. a -> b -> a
const forall a. Eq a => a -> a -> Bool
(==)
  }

{-------------------------------------------------------------------------------
  The actual generic function
-------------------------------------------------------------------------------}

glens :: forall r w a c xs.
         ( Monad r
         , Monad w
         , HasDatatypeInfo a
         , c a
         , Code a ~ '[xs]
         , All (CLens r w c) xs
         )
      => LensOptions -> Path -> Either String (AbstractLens r w c a)
glens :: forall (r :: * -> *) (w :: * -> *) a (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, HasDatatypeInfo a, c a, Code a ~ '[xs],
 All (CLens r w c) xs) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
glens LensOptions
_    []     = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId
glens LensOptions
opts (FieldName
p:Path
ps) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
`afterGLens` (forall (r :: * -> *) (w :: * -> *) (f :: * -> *) (xs :: [*]).
(Monad r, Monad w) =>
GLens r w (SOP f '[xs]) (NP f xs)
GLens.sop forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (r :: * -> *) (w :: * -> *) a.
(Monad r, Monad w, Generic a) =>
GLens r w a (Rep a)
GLens.rep))
                         forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> FieldName
-> Path
-> DatatypeInfo '[xs]
-> Either FieldName (AbstractLens r w c (NP I xs))
glens' LensOptions
opts FieldName
p Path
ps
                         forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

glens' :: ( Monad r
          , Monad w
          , All (CLens r w c) xs
          )
       => LensOptions -> String -> Path
       -> DatatypeInfo '[xs]
       -> Either String (AbstractLens r w c (NP I xs))
glens' :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> FieldName
-> Path
-> DatatypeInfo '[xs]
-> Either FieldName (AbstractLens r w c (NP I xs))
glens' LensOptions
opts FieldName
p Path
ps DatatypeInfo '[xs]
d =
  forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> Path
-> FieldName
-> FieldName
-> ConstructorInfo xs
-> Either FieldName (AbstractLens r w c (NP I xs))
glens'' LensOptions
opts Path
ps (forall (xss :: [[*]]). DatatypeInfo xss -> FieldName
datatypeName DatatypeInfo '[xs]
d) FieldName
p (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))

glens'' :: forall r w c xs.
           ( Monad r
           , Monad w
           , All (CLens r w c) xs
           )
        => LensOptions -> Path
        -> DatatypeName -> String
        -> ConstructorInfo xs
        -> Either String (AbstractLens r w c (NP I xs))
glens'' :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
       (xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> Path
-> FieldName
-> FieldName
-> ConstructorInfo xs
-> Either FieldName (AbstractLens r w c (NP I xs))
glens'' LensOptions
_ Path
_ FieldName
_ FieldName
_ (Constructor FieldName
_) =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Cannot compute lenses for non-record types"
glens'' LensOptions
_ Path
_ FieldName
_ FieldName
_ (Infix FieldName
_ Associativity
_ Fixity
_) =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Cannot compute lenses for non-record types"
glens'' LensOptions
opts Path
ps FieldName
d FieldName
p (Record FieldName
_ NP FieldInfo xs
fs) =
    case [Either FieldName (AbstractLens r w c (NP I xs))]
matchingLenses of
      []  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Unknown field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
p forall a. [a] -> [a] -> [a]
++ FieldName
" of datatype " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
d
      [Either FieldName (AbstractLens r w c (NP I xs))
l] -> Either FieldName (AbstractLens r w c (NP I xs))
l
      [Either FieldName (AbstractLens r w c (NP I xs))]
_   -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Invalid metadata for datatype " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
d
  where
    matchingLenses :: [Either String (AbstractLens r w c (NP I xs))]
    matchingLenses :: [Either FieldName (AbstractLens r w c (NP I xs))]
matchingLenses = forall a. [Maybe a] -> [a]
catMaybes forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (CLens r w c)
pl forall a.
CLens r w c a =>
FieldInfo a
-> GLens r w (NP I xs) a
-> K (Maybe (Either FieldName (AbstractLens r w c (NP I xs)))) a
aux NP FieldInfo xs
fs forall (r :: * -> *) (w :: * -> *) (xs :: [*]).
(Monad r, Monad w, SListI xs) =>
NP (GLens r w (NP I xs)) xs
GLens.np

    aux :: forall a. CLens r w c a
        => FieldInfo a
        -> GLens r w (NP I xs) a
        -> K (Maybe (Either String (AbstractLens r w c (NP I xs)))) a
    aux :: forall a.
CLens r w c a =>
FieldInfo a
-> GLens r w (NP I xs) a
-> K (Maybe (Either FieldName (AbstractLens r w c (NP I xs)))) a
aux (FieldInfo FieldName
f) GLens r w (NP I xs) a
l = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$
      if LensOptions -> FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch LensOptions
opts FieldName
d FieldName
f FieldName
p
        then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ((forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
`afterGLens` GLens r w (NP I xs) a
l) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a.
CLens r w c a =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
lens LensOptions
opts Path
ps)
        else forall a. Maybe a
Nothing

    pl :: Proxy (CLens r w c)
    pl :: Proxy (CLens r w c)
pl = forall {k} (t :: k). Proxy t
Proxy