{- |

Description : labels which are also lenses (or prisms)

A simple problem is being solved here, but unfortunately it
is a bit involved. The idea is to use the same haskell identifier
for a lens and for other purposes. In other words, get the same
behavior as:

 > x = hLens (Label :: Label "x")
 > r ^. x

While still being able to extract the symbol \"x\" from x, so that things
like @x .=. 123@ could be acceptable. In this case we don't overload '.=.',
so instead you have to write @x .==. 123@.


Elaboration of some ideas from edwardk.
-}
module Data.HList.Labelable
    (Labelable(..),
     LabeledOptic,
     (.==.),


     -- * multiple lookups
     Projected(..), projected',

    -- * comparison with 'hLens'
    -- $comparisonWithhLensFunction

    -- * likely unneeded (re)exports
    LabeledCxt1,
    LabeledTo(LabeledTo),
    LabeledR(LabeledR),
    ToSym(toLabel),
    Identity,
    LabelableTIPCxt,
    LabeledOpticType(..),

    LabeledOpticF,
    LabeledOpticP,
    LabeledOpticTo,
    ) where



import Data.HList.HListPrelude
import Data.HList.FakePrelude
import Data.HList.Record
import Data.HList.Variant
import Data.HList.TIP
import Data.HList.TIC
import Data.HList.Label3

import Control.Monad.Identity
import GHC.TypeLits
import LensDefs
import GHC.Exts (Constraint)

{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic
is a type parameter 'to' in LabeledOptic.

Depending on the collection type (see instances of 'LabelableTy'),
the type variables @to, p, f@ are constrained such that the resulting
type is a @Lens (r s) (r t) a b@, @Prism (r s) (r t) a b@ or a
@LabeledTo x _ _@. The latter can be used to recover the label (@x@) when
used as an argument to '.==.' or equivalently 'toLabel'.
-}
type LabeledOptic (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) (a :: *) (b :: *)
    = forall ty to p f.
                     (ty ~ LabelableTy r,
                      LabeledOpticF ty f,
                      LabeledOpticP ty p,
                      LabeledOpticTo ty x to) => (a `p` f b) `to` (r s `p` f (r t))

data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel

type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint
type instance LabeledOpticF LabelableLens = Functor
type instance LabeledOpticF LabelablePrism = Applicative
type instance LabeledOpticF LabelableLabel = (~) Identity

type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint
type instance LabeledOpticP LabelableLens = (~) (->)
type instance LabeledOpticP LabelablePrism = Choice
type instance LabeledOpticP LabelableLabel = (~) (->)

type family LabeledOpticTo (ty :: LabeledOpticType) (x :: k) :: (* -> * -> *) -> Constraint
type instance LabeledOpticTo LabelableLens x = (~) (->)
type instance LabeledOpticTo LabelablePrism x = (~) (->)
type instance LabeledOpticTo LabelableLabel x = (~) (LabeledTo x)


{- |

[@r@] is 'Record', 'Variant'. 'TIP' and 'TIC' also have instances, but generally
'tipyLens'' and 'ticPrism'' are more appropriate.

[@x@] is the label for the field. It tends to have kind 'GHC.TypeLits.Symbol',
but others are supported in principle.

-}
class SameLength s t => Labelable (x :: k) (r :: [*] -> *) s t a b
          | x s -> a, x t -> b,    -- lookup
            x s b -> t, x t a -> s -- update
  where
    type LabelableTy r :: LabeledOpticType
    hLens' :: Label x -> LabeledOptic x r s t a b

data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show)

data LabeledR (x :: [*]) = LabeledR


-- | make a @Lens (Record s) (Record t) a b@
instance HLens x Record s t a b
        => Labelable x Record s t a b where
            type LabelableTy Record = LabelableLens
            hLens' = hLens

-- | used with 'toLabel' and/or '.==.'
instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where
        type LabelableTy LabeledR = LabelableLabel
        hLens' _ = LabeledTo

-- | sets all type variables to dummy values: only the @Labeled x@
-- part is actually needed
type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ())

-- | make a @Prism (Variant s) (Variant t) a b@
instance (HPrism x s t a b,
          to ~ (->)) => Labelable x Variant s t a b where
    type LabelableTy Variant = LabelablePrism
    hLens' x s = hPrism x s

-- | @hLens' :: Label a -> Prism' (TIC s) a@
--
-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@,
-- cannot have an instance of Labelable
instance (TICPrism s t a b, x ~ a, a ~ b, s ~ t,
          SameLength s t) =>
    Labelable (x :: *) TIC s t a b where
      type LabelableTy TIC = LabelablePrism
      hLens' _ = ticPrism


-- | make a @Lens' (TIP s) a@.
--
-- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need
-- too many type annotations to be practical
instance LabelableTIPCxt x s t a b =>
    Labelable x TIP s t a b where
    type LabelableTy TIP = LabelableLens
    hLens' = hLens

type LabelableTIPCxt x s t a b =
     (s ~ t, a ~ b, x ~ a,
      HLens x TIP s t a b)


-- | modification of '.=.' which works with the labels from this module,
-- and those from "Data.HList.Label6". Note that this is not strictly a
-- generalization of '.=.', since it does not work with labels like
-- "Data.HList.Label3" which have the wrong kind.
l .==. v = toLabel l .=. v

infixr 4 .==.


{- | Create a @'Label' (x :: 'Symbol')@:

> toLabel :: LabeledTo x _ _ -> Label x
> toLabel :: Label x         -> Label x
> toLabel :: Proxy x         -> Label x

-}
class ToSym label (s :: Symbol) | label -> s where
    toLabel :: label -> Label s

instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3
    => ToSym (v1 v2 v3) x where
      toLabel _ = Label

instance ToSym (label x) x where
    toLabel _ = Label


{- $comparisonWithhLensFunction

Note that passing around variables defined with 'hLens'' doesn't get
you exactly the same thing as calling 'hLens' at the call-site:

The following code needs to apply the @x@ for different @Functor
f =>@, so you would have to write a type signature (rank-2) to allow this
definition:

 > -- with the x defined using hLens'
 > let f x r = let
 >          a = r ^. x
 >          b = r & x .~ "6"
 >        in (a,b)

This alternative won't need a type signature

 > -- with the x defined as x = Label :: Label "x"
 > let f x r = let
 >          a = r ^. hLens x
 >          b = r & hLens x .~ "6"
 >        in (a,b)

It may work to use 'hLens'' instead of 'hLens' in the second code,
but that is a bit beside the point being made here.

The same points apply to the use of 'hPrism' over 'hLens''.

-}

{- | Sometimes it may be more convenient to operate on a record/variant
that only contains the fields of interest. 'projected' can then be used
to apply that function to a record that contains additional elements.


>>> :set -XViewPatterns
>>> import Data.HList.RecordPuns
>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |]
>>> :t f
f :: Num v =>
     Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v]

>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |])
>>> r
Record{x=1,y=2,z=()}

>>> r & sameLabels . projected %~ f
Record{x=1,y=2,z=3}




-}
class Projected r s t a b where
    projected :: (ty ~ LabelableTy r,
                LabeledOpticP ty p,
                LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t)

-- | @Lens rs rt ra rb@
--
-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@
instance (-- for Record s -> Record a
          H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a,
          HRLabelSet a_, HRLabelSet a,
          HRearrange (LabelsOf a) a_ a,

          HLeftUnion b s bs, HRLabelSet bs,
          HRearrange (LabelsOf t) bs t, HRLabelSet t
        ) => Projected Record s t a b where
    projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a)

-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@
instance (ExtendsVariant b t,
          ProjectVariant s a,
          ProjectExtendVariant s t,

          HLeftUnion b s bs, HRLabelSet bs,
          HRearrange (LabelsOf t) bs t)
      => Projected Variant s t a b where
    projected = prism extendsVariant
            (\s -> case projectVariant s of
                    Just a -> Right a
                    Nothing | Just t <- projectExtendVariant s -> Left t
                    _ -> error "Data.HList.Labelable.projected impossible"
                    -- projectExtendVariant gives Nothing when the element of
                    -- `t` that is actually stored in the variant comes
                    -- from the `b`. But in that case the projectVariant
                    -- above must have been Just
              )


{- | @Lens' (Record s) (Record a)@

@Prism' (Variant s) (Variant a)@
-}
projected' s = simple (projected (simple s))


{- | Together with the instance below, this allows writing

@
'makeLabelable' "x y z"
p = x .*. y .*. z .*. 'emptyProxy'
@

Or with HListPP

@
p = `x .*. `y .*. `z .*. emptyProxy
@

instead of

> p = Proxy :: Proxy ["x","y","z"]

-}
instance (to ~ LabeledTo x, ToSym (to p q) x)
       => HExtend (to p q) (Proxy ('[] :: [*])) where
    type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to]
    (.*.) _ _ = Proxy

instance (to ~ LabeledTo x, ToSym (to p q) x)
       => HExtend (to p q) (Proxy (x ': xs)) where
    type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs)
    (.*.) _ _ = Proxy

-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be
-- wrapped in Label to make the kinds match up.
instance (to ~ LabeledTo x, ToSym (to p q) x)
       => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where
    type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs))
        = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs))
    (.*.) _ _ = Proxy

type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol
type instance GetXFromLabeledTo (LabeledTo x) = x