pointless-lenses-0.0.8: src/Generics/Pointless/DLenses/RecursionPatterns.hs
-----------------------------------------------------------------------------
-- |
-- Module : Generics.Pointless.DLenses.RecursionPatterns
-- Copyright : (c) 2011 University of Minho
-- License : BSD3
--
-- Maintainer : hpacheco@di.uminho.pt
-- Stability : experimental
-- Portability : non-portable
--
-- Pointless Lenses:
-- bidirectional lenses with point-free programming
--
-- This module provides catamorphism and anamorphism bidirectional combinators for the definition of recursive delta-lenses.
--
-----------------------------------------------------------------------------
module Generics.Pointless.DLenses.RecursionPatterns where
import Data.Relation
import Data.Shape
import Data.Diff
import Generics.Pointless.DLenses
import Generics.Pointless.DLenses.Combinators
import Generics.Pointless.DLenses.ShapeCombinators
import Generics.Pointless.HFunctors
import Generics.Pointless.Functors
import Generics.Pointless.Combinators
import Data.Set (Set)
import qualified Data.Set as Set
-- | Inn isomorphism delta lens
hinn_dlns :: (Hu s,Shapely s,Shapely (H s s)) => DLens (H s s) a s a
hinn_dlns = DLens get' getd' put' putd' create' created'
where get' s = hinn s
getd' s = locsR s
put' (v,s) dV = hout v
putd' v s dV = inlPosR (v,s)
create' v = hout v
created' v = locsR v
-- | Out isomorphism delta lens
hout_dlns :: (Hu s,Shapely s,Shapely (H s s)) => DLens s a (H s s) a
hout_dlns = DLens get' getd' put' putd' create' created'
where get' s = hout s
getd' s = locsR s
put' (v,s) dV = hinn v
putd' v s dV = inlPosR (v,s)
create' v = hinn v
created' v = locsR v
class SHFunctor (f :: (* -> *) -> (* -> *)) (g :: * -> *) (h :: * -> *) where
-- | Higher-order functor mapping (on shapes)
hmap_dlns :: (Shapely (HRep f g),Shapely (HRep f h)) => AnnH f -> DLens g a h a -> DLens (HRep f g) a (HRep f h) a
-- | Higher-order functor strength (on shapes)
hstrength :: Shapely g => AnnH f -> ((HRep f h) a,g a) -> DLens g a h a -> Delta ((HRep f h) a) (h a) -> (HRep f g) a
-- | Horizontal delta produced by the higher-order functor strength combinator
hstrengthd :: Shapely g => AnnH f -> (HRep f h) a -> g a -> DLens g a h a -> Delta ((HRep f h) a) (h a) -> Delta ((HRep f g) a) ((HRep f h) a,g a)
instance SHFunctor HId x y where
hmap_dlns _ l = l
hstrength _ (fv,s) l dV = put l (fv,s) dV
hstrengthd _ fv s l dV = putd l fv s dV
instance SHFunctor (HConst c) x y where
hmap_dlns _ l = id_dlns
hstrength _ (fv,s) l dV = fv
hstrengthd _ fv s l dV = inlPosR (fv,s)
instance SHFunctor HParam x y where
hmap_dlns _ l = id_dlns
hstrength _ (fv,s) l dV = fv
hstrengthd _ fv s l dV = inlPosR (fv,s)
instance Shapely f => SHFunctor (HFun f) x y where
hmap_dlns _ l = id_dlns
hstrength _ (fv,s) l dV = fv
hstrengthd _ fv s l dV = inlPosR (fv,s)
instance (Shapely (HRep f y),Shapely (HRep f x),Shapely (HRep g y),Shapely (HRep g x),SHFunctor f x y,SHFunctor g x y) => SHFunctor (f :*~: g) x y where
hmap_dlns (_::AnnH (f:*~:g)) l = hmap_dlns (ann::AnnH f) l ><<~ hmap_dlns (ann::AnnH g) l
hstrength (_::AnnH (f:*~:g)) (ProdF fv gv,s) l dV = ProdF (hstrength (ann::AnnH f) (fv,s) l d1) (hstrength (ann::AnnH g) (gv,s) l d2)
where d1 = dV .~ inlPosR (fv,gv)
d2 = dV .~ inrPosR (fv,gv)
hstrengthd (_::AnnH (f:*~:g)) p@(ProdF fv gv) s l dV = eitherPosR (hstrength (ann::AnnH f) (fv,s) l d1,hstrength (ann::AnnH g) (gv,s) l d2)
(sumPosR (fv,s) (p,s) (inlPosR (fv,gv)) (locsR s) .~ hstrengthd (ann::AnnH f) fv s l d1)
(sumPosR (gv,s) (p,s) (inrPosR (fv,gv)) (locsR s) .~ hstrengthd (ann::AnnH g) gv s l d2)
where d1 = dV .~ inlPosR (fv,gv)
d2 = dV .~ inrPosR (fv,gv)
instance (Shapely (HRep f y),Shapely (HRep f x),Shapely (HRep g y),Shapely (HRep g x),SHFunctor f x y,SHFunctor g x y) => SHFunctor (f :+~: g) x y where
hmap_dlns (_::AnnH (f:+~:g)) l = hmap_dlns (ann::AnnH f) l -|-<~ hmap_dlns (ann::AnnH g) l
hstrength (_::AnnH (f:+~:g)) (InlF fv,s) l dV = InlF $ hstrength (ann::AnnH f) (fv,s) l dV
hstrength (_::AnnH (f:+~:g)) (InrF gv,s) l dV = InrF $ hstrength (ann::AnnH g) (gv,s) l dV
hstrengthd (_::AnnH (f:+~:g)) (InlF fv) s l dV = hstrengthd (ann::AnnH f) fv s l dV
hstrengthd (_::AnnH (f:+~:g)) (InrF gv) s l dV = hstrengthd (ann::AnnH g) gv s l dV
-- | Higher-order catamorphism delta lens
cata_dlns :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
, SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
, Shapely (H s s),Shapely (H s v),Shapely (HRep (HF s) (Const One))
)
=> Ann (Fix s) -> DLens (H s v) a v a -> DLens s a v a
cata_dlns (anns::Ann (Fix s)) l = DLens get' getd' put' putd' create' created'
where get' x = get cata x
getd' x = getd cata x
put' (y::v a,x) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrink_cata anns l (y,x) dV
| Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = grow_cata anns l (y,x) dV
| otherwise = put cata (y,x) dV
where -- all the elements at the head of the original source not deleted by get
setS = rng $ inv (getd' x) .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> s a))) (hout x)
-- all the elements at the head of the modified view
setV = rng $ created l y .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> v a))) (create l y)
putd' (y::v a) x dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrinkd_cata anns l y x dV
| Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = growd_cata anns l y x dV
| otherwise = putd cata y x dV
where setS = rng $ inv (getd' x) .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> s a))) (hout x)
setV = rng $ created l y .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> v a))) (create l y)
create' y = create cata y
created' y = created cata y
cata = l .<~ hmap_dlns annf (cata_dlns anns l) .<~ hout_dlns
annf = ann :: AnnH (HF s)
shrink_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
, SHFunctor (HF s) s v,SHFunctor (HF s) v (Const One),SHFunctor (HF s) s (Const One)
, Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One)),Shapely (HRep (HF s) s)
)
=> Ann (Fix s) -> DLens (H s v) a v a -> (v a,s a) -> Delta (v a) (v a) -> s a
shrink_cata (anns::Ann (Fix s)) l (y,x) dG = put (cata_dlns anns l) (y,x') dV
where -- reduced source
x' = reduce' annf anns (hout x)
reduceh = dnat (reduce' annf anns) (hout x)
dV = inv (getd (cata_dlns anns l) x') .~ inv reduceh .~ getd (cata_dlns anns l) x .~ dG
annf = ann :: AnnH (HF s)
shrinkd_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
, SHFunctor (HF s) s v,SHFunctor (HF s) v (Const One),SHFunctor (HF s) s (Const One)
, Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One)),Shapely (HRep (HF s) s)
)
=> Ann (Fix s) -> DLens (H s v) a v a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
shrinkd_cata (anns::Ann (Fix s)) l y x dG = sumPosR (y,x') (y,hout x) (locsR y) reduceh .~ putd (cata_dlns anns l) y x' dV
where -- reduced source
x' = reduce' annf anns (hout x)
reduceh = dnat (reduce' annf anns) (hout x)
dV = inv (getd (cata_dlns anns l) x') .~ inv reduceh .~ getd (cata_dlns anns l) x .~ dG
annf = ann :: AnnH (HF s)
grow_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
, SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
, Shapely (H s s),Shapely (H s v),Shapely (H s (Const One))
)
=> Ann (Fix s) -> DLens (H s v) a v a -> (v a,s a) -> Delta (v a) (v a) -> s a
grow_cata (anns::Ann (Fix s)) l (y,x) dG = hinn $ hstrength annf (create l y,x) (cata_dlns anns l) dG
where dV = dG .~ created l y
annf = ann :: AnnH (HF s)
growd_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
, SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
, Shapely (HRep (HF s) s),Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One))
)
=> Ann (Fix s) -> DLens (H s v) a v a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
growd_cata (anns::Ann (Fix s)) l y x dG = sumPosR (create l y,x) (y,x) (created l y) (locsR x) .~ hstrengthd annf (create l y) x (cata_dlns anns l) dG
where dV = dG .~ created l y
annf = ann :: AnnH (HF s)
-- | Higher-order anamorphism delta lens
ana_dlns :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
, SHFunctor (HF v) s v,SHFunctor (HF v) v (Const One),SHFunctor (HF v) s (Const One)
, Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
)
=> Ann (Fix v) -> DLens s a (H v s) a -> DLens s a v a
ana_dlns (annv::Ann (Fix v)) l = DLens get' getd' put' putd' create' created'
where get' x = get ana x
getd' x = getd ana x
put' (y,x::s a) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrink_ana annv l (y,x) dV
| Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = grow_ana annv l (y,x) dV
| otherwise = put ana (y,x) dV
where -- all the elements at the head of the original source not abstracted by get
setS = rng $ inv (getd ana x) .~ getd l x .~ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> s a))) (get l x)
-- all the elements at the head of the modified view
setV = rng $ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> v a))) (hout y)
putd' y (x::s a) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrinkd_ana annv l y x dV
| Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = growd_ana annv l y x dV
| otherwise = putd ana y x dV
where setS = rng $ inv (getd ana x) .~ getd l x .~ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> s a))) (get l x)
setV = rng $ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> v a))) (hout y)
create' y = create ana y
created' y = created ana y
ana = hinn_dlns .<~ hmap_dlns anng (ana_dlns annv l) .<~ l
anng = ann :: AnnH (HF v)
shrink_ana :: ( Hu v,FMonoid s,HFoldable (HF v),Shapely s,Shapely v
, SHFunctor (HF v) s v,SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One)
, Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
)
=> Ann (Fix v) -> DLens s a (H v s) a -> (v a,s a) -> Delta (v a) (v a) -> s a
shrink_ana (annv::Ann (Fix v)) l (y,x::s a) dG = put (ana_dlns annv l) (y,x') dV
where -- reduced source
x' = reduce' anng anns (get l x)
reduceh = dnat (reduce' anng anns) (get l x)
dV = inv (getd (ana_dlns annv l) x') .~ inv reduceh .~ inv (getd l x) .~ getd (ana_dlns annv l) x .~ dG
anng = ann :: AnnH (HF v)
anns = ann :: Ann (Fix s)
shrinkd_ana :: ( Hu v,FMonoid s,HFoldable (HF v),Shapely s,Shapely v
, SHFunctor (HF v) s v,SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One)
, Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
)
=> Ann (Fix v) -> DLens s a (H v s) a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
shrinkd_ana (annv::Ann (Fix v)) l y (x::s a) dG = sumPosR (y,x') (y,x) (locsR y) (getd l x .~ reduceh) .~ putd (ana_dlns annv l) y x' dV
where -- reduced source
x' = reduce' anng anns (get l x)
reduceh = dnat (reduce' anng anns) (get l x)
dV = inv (getd (ana_dlns annv l) x') .~ inv reduceh .~ inv (getd l x) .~ getd (ana_dlns annv l) x .~ dG
anng = ann :: AnnH (HF v)
anns = ann :: Ann (Fix s)
grow_ana :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
, SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One),SHFunctor (HF v) s v
, Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
)
=> Ann (Fix v) -> DLens s a (H v s) a -> (v a,s a) -> Delta (v a) (v a) -> s a
grow_ana (annv::Ann (Fix v)) l (y,x) dG = create l $ hstrength anng (hout y,x) (ana_dlns annv l) dV
where dV = dG
anng = ann :: AnnH (HF v)
growd_ana :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
, SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One),SHFunctor (HF v) s v
, Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
)
=> Ann (Fix v) -> DLens s a (H v s) a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
growd_ana (annv::Ann (Fix v)) l y x dG = hstrengthd anng (hout y) x (ana_dlns annv l) dV .~ created l y'
where -- grown view
y' = hstrength anng (hout y,x) (ana_dlns annv l) dV
dV = dG
anng = ann :: AnnH (HF v)