pointless-lenses-0.0.8: src/Generics/Pointless/DLenses/ShapeCombinators.hs
-----------------------------------------------------------------------------
-- |
-- Module : Generics.Pointless.DLenses.ShapeCombinators
-- 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 specific delta-lens combinators over shapes.
--
-----------------------------------------------------------------------------
module Generics.Pointless.DLenses.ShapeCombinators where
import Data.Shape
import Data.Relation
import Data.Diff
import Generics.Pointless.Lenses (Lens)
import qualified Generics.Pointless.Lenses as Lns
import Generics.Pointless.DLenses
import Generics.Pointless.HFunctors
import Generics.Pointless.Functors
import Generics.Pointless.Combinators
import Data.List as List
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
-- | Lifts a regular lens to a lens on structure
liftConst_dlns :: Lens s v -> DLens (Const s) a (Const v) b
liftConst_dlns l = DLens get' getd' put' putd' create' created'
where get' (ConsF s) = ConsF (Lns.get l s)
getd' s = emptyR
put' (ConsF v,ConsF s) dV = ConsF (Lns.put l (v,s))
putd' v s dV = emptyR
create' (ConsF v) = ConsF (Lns.create l v)
created' v = emptyR
-- | Lifts a regular lens to a lens on data elements
liftId_dlns :: Lens a b -> DLens Id a Id b
liftId_dlns l = map_dlns l
-- | Maps a normal lens over a functor
-- This combinator uses the update delta to infer insertions, deletions and reorderings
map_dlns :: Shapely s => Lens a b -> DLens s a s b
map_dlns l = DLens get' getd' put' putd' create' created'
where get' s = smap (Lns.get l) s
getd' s = locsR s
put' (v,s) dV = fst (traverse aux (v,0))
where aux (b,i) | Set.size js > 0 = (Lns.put l (b,a),succ i)
| otherwise = (Lns.create l b,succ i)
where js = rngOf i dV
a = data_(s)!!(Set.findMin js)
putd' v s dV = inlPosR (v,s)
create' v = smap (Lns.create l) v
created' v = locsR v
-- | Converts a natural transformation of Reps to a natural transformation on functors
repnat :: (ToRep s,ToRep v) => Ann (Fix v) -> (forall a. Ann a -> Rep s a -> Rep v a) -> (s :~> v)
repnat v f sa = unrep v (val sa) $ f (val sa) (rep sa)
-- | Infers an horizontal delta from a natural transformation
dnat :: (Shapely s,Shapely v) => (s :~> v) -> s a -> Delta (v a) (s a)
dnat f sa = mkRel $ zip vi (data_ (f si))
where va = f sa
si = recover (shape sa,Set.toList (locs sa))
vi = Set.toList (locs va)
-- | Lifts a regular natural transformation lens into a shapely lens
nat_dlns :: (Shapely s,Shapely v,ToRep s,ToRep v) => Lns.NatLens s v -> NatDLens s v
nat_dlns l = DLens get' getd' put' putd' create' created'
where get' s = repnat annv (\a -> Lns.get (l a)) s
getd' s = dnat (repnat annv (\a -> Lns.get (l a))) s
put' (v,s) dV = repnat anns (\a -> Lns.put (l a)) (ProdF v s)
putd' v s dV = dnat (repnat anns (\a -> Lns.put (l a))) (ProdF v s)
create' v = repnat anns (\a -> Lns.create (l a)) v
created' v = dnat (repnat anns (\a -> Lns.create (l a))) v
anns = ann :: Ann (Fix s)
annv = ann :: Ann (Fix v)
-- | Explicti bias for semantic bidirectionalization (needs to be a reordering on lists, i.e., preserve the chunks)
type Bias = forall a. [a] -> [a]
rear_bias = id
front_bias = reverse
-- | Combinators that simulates the mixed syntactic and semantic bidirectional approach
-- We require that shape . f = get skel . shape
sem_dlns :: (Shapely s,Shapely v) => a -> Bias -> Lens (s One) (v One) -> (s :~> v) -> DLens s a v a
sem_dlns d bias skel f = DLens get' getd' put' putd' create' created'
where get' s = f s
getd' s = dnat f s
put' (v,s) dV = recover (shapeS',IntMap.elems $ IntMap.union gv gs)
where shapeV = smap bang v
shapeS = smap bang s
shapeS' = Lns.put skel (shapeV,shapeS)
locsS = Set.toList (locs shapeS)
locsS' = Set.toList (locs shapeS')
si = recover (shapeS,locsS)
si' = recover (shapeS',locsS')
-- elements of the original view that are copied to the new source
gv = IntMap.fromDistinctAscList $ zip (data_ $ f si') (data_ v)
-- elements retrieved from the original source (just the ones not abstracted by get) and defaults
-- the new source values are put positionally, but may be generalized into a bias
gs = IntMap.fromDistinctAscList $ zip
(bias $ locsS' \\ (data_ $ f si'))
(map (data_ s!!) (bias $ locsS \\ (data_ $ f si)) ++ repeat d)
putd' v s dV = (inlPosR (v,s) .~ viewR) `unionR` (inrPosR (v,s) .~ srcR)
where shapeV = smap bang v
shapeS = smap bang s
shapeS' = Lns.put skel (shapeV,shapeS)
locsS = Set.toList (locs shapeS)
locsV = Set.toList (locs shapeV)
locsS' = Set.toList (locs shapeS')
si = recover (shapeS,locsS)
si' = recover (shapeS',locsS')
viewR = mkRel $ zip (data_ $ f si') locsV
srcR = mkRel $ zip (bias $ locsS' \\ (data_ $ f si')) (bias $ locsS \\ (data_ $ f si))
create' v = recover (shapeS,IntMap.elems $ IntMap.union gv gs)
where shapeV = smap bang v
shapeS = Lns.create skel shapeV
locsS = Set.toList (locs shapeS)
si = recover (shapeS,locsS)
-- elements of the original view that are copied to the created source
-- the trick is to know that f . create skel = id
gv = IntMap.fromDistinctAscList $ zip (data_ $ f si) (data_ v)
-- new default elements
gs = IntMap.fromDistinctAscList $ zip locsS (repeat d)
-- only the non-default elements are relevant to the horizontal delta
created' v = mkRel $ zip (data_ $ f si) locsV
where shapeV = smap bang v
shapeS = Lns.create skel shapeV
locsV = Set.toList (locs shapeV)
locsS = Set.toList (locs shapeS)
si = recover (shapeS,locsS)
-- | Transformation between isomorphic functors applied to the same data
-- if they have the same shape then they must have the same locations
-- we also need the same data to be able to convert losslessly between them
coerce_dlns :: (Shapely s,Shapely v,ToRep s, ToRep v,Rep s One ~ Rep v One,Rep s a ~ Rep v a) => DLens s a v a
coerce_dlns = DLens get' getd' put' putd' create' created'
where get' s = unrep annv (val s) (rep s)
getd' s = locsR s
put' (v,s) dV = create' v
putd' v s dV = inlPosR (v,s)
create' v = unrep anns (val v) (rep v)
created' v = locsR v
anns = ann :: Ann (Fix s)
annv = ann :: Ann (Fix v)