{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Diverse.Lens.Many (
_Many
, _Many'
, Has(..)
, item'
, Had(..)
, HasL(..)
, HadL(..)
, HasTag(..)
, HadTag(..)
, HasN(..)
, HadN(..)
, Project
, project
, Project'
, project'
, ProjectL
, projectL
, ProjectL'
, projectL'
, ProjectN
, projectN
, ProjectN'
, projectN'
) where
import Control.Lens
import Data.Diverse.Many
import Data.Diverse.TypeLevel
import Data.Generics.Product
import Data.Has
import Data.Kind
import Data.Tagged
import GHC.TypeLits
_Many :: IsMany t xs a => Iso' (Many xs) (t xs a)
_Many = iso fromMany toMany
_Many' :: IsMany Tagged xs a => Iso' (Many xs) a
_Many' = iso fromMany' toMany'
item' :: Has a s => Lens' s a
item' = hasLens
instance UniqueMember x xs => Has x (Many xs) where
hasLens = lens grab replace'
class (Has a s, Replaced a a s ~ s) => Had a s where
type Replaced a b s
item :: Lens s (Replaced a b s) a b
instance (UniqueMember x xs) => Had x (Many xs) where
type Replaced x b (Many xs) = Many (Replace x b xs)
item = lens grab (replace @x)
class HasL (l :: k) a s | s l -> a where
itemL' :: Lens' s a
instance (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => HasL l x (Many xs) where
itemL' = lens (grabL @l) (replaceL' @l)
class (HasL (l :: k) a s, ReplacedL l a a s ~ s) => HadL (l :: k) a s | s l -> a where
type ReplacedL l a b s
itemL :: Lens s (ReplacedL l a b s) a b
instance (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => HadL l x (Many xs) where
type ReplacedL l x b (Many xs) = Many (Replace (KindAtLabel l xs) b xs)
itemL = lens (grabL @l) (replaceL @l)
class HasL l (Tagged l a) s => HasTag (l :: k) a s where
itemTag' :: Lens' s a
instance HasL l (Tagged l a) s => HasTag (l :: k) a s where
itemTag' = itemL' @l . iso unTagged Tagged
class HadL l (Tagged l a) s => HadTag (l :: k) a s where
itemTag :: Lens s (ReplacedL l (Tagged l a) (Tagged l b) s) a b
instance HadL l (Tagged l a) s => HadTag (l :: k) a s where
itemTag = itemL @l . iso unTagged (Tagged @l)
class HasN (n :: Nat) a s | s n -> a where
itemN' :: Lens' s a
instance (MemberAt n x xs) => HasN n x (Many xs) where
itemN' = lens (grabN @n) (replaceN' @n)
class (HasN (n :: Nat) a s, ReplacedN n a a s ~ s) => HadN (n :: Nat) a s | s n -> a where
type ReplacedN n a b s
itemN :: Lens s (ReplacedN n a b s) a b
default itemN :: (HasPosition n s (ReplacedN n a b s) a b) => Lens s (ReplacedN n a b s) a b
itemN = position @n
instance (MemberAt n x xs)
=> HadN n x (Many xs) where
type ReplacedN n x b (Many xs) = Many (ReplaceIndex n x b xs)
itemN = lens (grabN @n) (replaceN @n)
type Project' (smaller :: [Type]) (larger :: [Type]) = (Select smaller larger, Amend' smaller larger)
project' :: forall smaller larger. Project' smaller larger => Lens' (Many larger) (Many smaller)
project' = lens select amend'
type Project (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =
( Select smaller larger
, Amend smaller smaller' larger
, larger' ~ Replaces smaller smaller' larger
)
project :: forall smaller smaller' larger larger'. Project smaller smaller' larger larger'
=> Lens (Many larger) (Many larger') (Many smaller) (Many smaller')
project = lens select (amend @smaller @smaller')
type ProjectL' (ls :: [k]) (smaller :: [Type]) (larger :: [Type]) =
( Select smaller larger
, Amend' smaller larger
, smaller ~ KindsAtLabels ls larger
, IsDistinct ls
, UniqueLabels ls larger
)
projectL' :: forall ls smaller larger. ProjectL' ls smaller larger => Lens' (Many larger) (Many smaller)
projectL' = lens (selectL @ls) (amendL' @ls)
type ProjectL (ls :: [k]) (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =
( Select smaller larger
, Amend smaller smaller' larger
, smaller ~ KindsAtLabels ls larger
, IsDistinct ls
, UniqueLabels ls larger
, larger' ~ Replaces smaller smaller' larger
)
projectL :: forall ls smaller smaller' larger larger'. ProjectL ls smaller smaller' larger larger'
=> Lens (Many larger) (Many larger') (Many smaller) (Many smaller')
projectL = lens (selectL @ls) (amendL @ls)
type ProjectN' (ns :: [Nat]) (smaller :: [Type]) (larger :: [Type]) =
(SelectN ns smaller larger, AmendN' ns smaller larger)
projectN' :: forall ns smaller larger. ProjectN' ns smaller larger => Lens' (Many larger) (Many smaller)
projectN' = lens (selectN @ns) (amendN' @ns)
type ProjectN (ns :: [Nat]) (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =
(SelectN ns smaller larger, AmendN ns smaller smaller' larger, larger' ~ ReplacesIndex ns smaller' larger)
projectN :: forall ns smaller smaller' larger larger'. ProjectN ns smaller smaller' larger larger'
=> Lens (Many larger) (Many larger') (Many smaller) (Many smaller')
projectN = lens (selectN @ns) (amendN @ns)