-----------------------------------------------------------------------------
-- |
-- 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)