pointless-lenses-0.0.8: src/Generics/Pointless/DLenses/Examples/Examples.hs

{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.DLenses.Examples.Examples
-- 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 examples of delta-lenses.
--
-----------------------------------------------------------------------------

module Generics.Pointless.DLenses.Examples.Examples where

import Data.Shape
import Generics.Pointless.DLenses.Combinators
import Generics.Pointless.DLenses.ShapeCombinators
import Generics.Pointless.DLenses
import Generics.Pointless.DLenses.RecursionPatterns
import Generics.Pointless.HFunctors
import Generics.Pointless.Lenses (Lens)
import qualified Generics.Pointless.Lenses as Lns
import Generics.Pointless.Lenses.Combinators
import Generics.Pointless.Lenses.Examples.Examples

import Generics.Pointless.Combinators
import Generics.Pointless.Functors

import qualified Data.Set as Set
import Test.QuickCheck hiding ((><))
import Data.DeriveTH

-- * Mapping

srcMap = [(1,'a'),(2,'b'),(3,'c')]
lnsMap :: DLens [] (Int,Char) [] Int
lnsMap = map_dlns (fst_lns (const 'x'))
getMap = get lnsMap srcMap
tgtMap = [0,3,1]
putMap = put lnsMap (tgtMap,srcMap) dV
    where dV = Set.fromList [(1,2),(2,0)]

checkMap = testDLens lnsMap

-- * Semantic

halve_dlns :: a -> DLens [] a [] a
halve_dlns d = sem_dlns d rear_bias skel halve
    where halve :: [a] -> [a]
          halve [] = []
          halve (x:xs) = x : halve' (xs,xs)
          halve' :: ([a],[a]) -> [a]
          halve' (xs,[]) = []
          halve' (xs,[y]) = []
          halve' (x:xs,y:z:zs) = x : halve' (xs,zs)
          skel = halve_lns _L

srcHalve = [1,2,3,4]
lnsHalve :: DLens [] Int [] Int
lnsHalve = halve_dlns (-1)
getHalve = get lnsHalve srcHalve
tgtHalve = [0,2,1]
createHalve = create lnsHalve tgtHalve
putHalve = put lnsHalve (tgtHalve,srcHalve) dV
    where dV = Set.fromList [(1,0),(2,1)]

invHalve = quickCheck (\s -> shape (Lns.get (halve_lns (_L::Int)) s) == shape (get (halve_dlns _L) s))
checkHalve = testDLens lnsHalve

-- * Filtering (user-defined)

data LE a = NilE | ConsE (Either a a) (LE a) deriving (Eq,Show)
$( derive makeArbitrary ''LE )
instance FMonoid LE where
    fzero = NilE
    fplus NilE l = l
    fplus l NilE = l
    fplus (ConsE x xs) r = ConsE x (fplus xs r)
type instance HF LE = HConst One :+~: (HParam :+~: HParam) :*~: HId
instance Hu LE where
    hout NilE = InlF $ ConsF _L
    hout (ConsE (Left x) xs) = InrF $ ProdF (InlF $ IdF x) xs
    hout (ConsE (Right x) xs) = InrF $ ProdF (InrF $ IdF x) xs
    hinn (InlF (ConsF _)) = NilE
    hinn (InrF (ProdF (InlF (IdF x)) xs)) = ConsE (Left x) xs
    hinn (InrF (ProdF (InrF (IdF x)) xs)) = ConsE (Right x) xs
instance Shapely LE where
    traverse f = (hinn >< id) . traverse f . (hout >< id)

filter_dlns :: DLens LE a [] a
filter_dlns = cata_dlns _L (((\/<~) p hinn_dlns (snd_dlns _L)) .<~ coassocl_dlns .<~ (id_dlns -|-<~ distl_dlns))
    where p _ = Left _L

srcFilter = ConsE (Left 1) $ ConsE (Right 5) $ ConsE (Left 2) $ ConsE (Right 6) NilE
tgtFilter = [0,1]
lnsFilter :: DLens LE Int [] Int
lnsFilter = filter_dlns
getFilter = get lnsFilter srcFilter
putFilter = put lnsFilter (tgtFilter,srcFilter) dV
    where dV = Set.fromList [(1,0)]

checkFilter = testDLens lnsFilter

-- * Filtering (composition fixed point)

instance (Arbitrary (f (g a))) => Arbitrary ((f :@: g) a) where
	arbitrary = do {x <- arbitrary; return (CompF x)}
instance (Arbitrary (f a),Arbitrary (g a)) => Arbitrary ((f :+: g) a) where
	arbitrary = oneof [do {x <- arbitrary; return (InlF x)},do {x <- arbitrary; return (InrF x)}]
instance (Arbitrary (f a),Arbitrary (g a)) => Arbitrary ((f :*: g) a) where
	arbitrary = do {x <- arbitrary; y <- arbitrary; return (ProdF x y)}
instance Arbitrary a => Arbitrary (Id a) where
	arbitrary = do {x <- arbitrary; return (IdF x)}
instance Arbitrary c => Arbitrary ((Const c) a) where
	arbitrary = do {x <- arbitrary; return (ConsF x)}
	
instance Hu ([] :@: (Id :+: Id)) where
    hout (CompF []) = InlF $ ConsF _L
    hout (CompF (x:xs)) = InrF $ ProdF x (CompF xs)
    hinn (InlF (ConsF _)) = CompF []
    hinn (InrF (ProdF x (CompF xs))) = CompF (x:xs)

filter'_dlns :: DLens ([] :@: (Id :+: Id)) a [] a
filter'_dlns = cata_dlns _L (((\/<~) p hinn_dlns (snd_dlns _L)) .<~ coassocl_dlns .<~ (id_dlns -|-<~ distl_dlns))
    where p _ = Left _L

srcFilter' = CompF [InlF (IdF 1),InrF (IdF 5),InlF (IdF 2),InrF (IdF 6)]
tgtFilter' = [0,1]
lnsFilter' :: DLens ([] :@: (Id :+: Id)) Int [] Int
lnsFilter' = filter'_dlns
getFilter' = get lnsFilter' srcFilter'
putFilter' = put lnsFilter' (tgtFilter',srcFilter') dV
    where dV = Set.fromList [(1,0)]

checkFilter' = testDLens lnsFilter'

-- * Tree left spine (fold)

data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Eq,Show)
$( derive makeArbitrary ''Tree )
instance Shapely Tree where
    traverse f = (hinn >< id) . traverse f . (hout >< id)
type instance HF Tree = HConst One :+~: HParam :*~: (HId :*~: HId)
instance Hu Tree where
    hout Empty = InlF $ ConsF _L
    hout (Node x l r) = InrF $ ProdF (IdF x) (ProdF l r)
    hinn (InlF (ConsF _)) = Empty
    hinn (InrF (ProdF (IdF x) (ProdF l r))) = Node x l r
instance FMonoid Tree where
    fzero = Empty
    fplus t Empty = t
    fplus t (Node x l r) = Node x (fplus t l) r

lspine_dlns :: DLens Tree a [] a
lspine_dlns = cata_dlns _L f
    where f = hinn_dlns .<~ (id_dlns -|-<~ id_dlns ><<~ fst_dlns g)
          g = const []

lnsSpine :: DLens Tree Int [] Int
lnsSpine = lspine_dlns
srcSpine = Node 1 (Node 2 Empty Empty) (Node 3 Empty Empty)
tgtSpine = [0,1,2]
getSpine = get lnsSpine srcSpine
putSpine = put lnsSpine (tgtSpine,srcSpine) dV
    where dV = Set.fromList [(1,0),(2,1)]

checkSpine = testDLens lnsSpine

-- * Tree left spine (unfold)

lspine'_dlns :: DLens Tree a [] a
lspine'_dlns = ana_dlns _L f
    where f = (id_dlns -|-<~ id_dlns ><<~ fst_dlns g) .<~ hout_dlns
          g = const Empty

lnsSpine' :: DLens Tree Int [] Int
lnsSpine' = lspine'_dlns
srcSpine' = Node 1 (Node 2 Empty Empty) (Node 3 Empty Empty)
tgtSpine' = [0,1,2]
getSpine' = get lnsSpine' srcSpine'
putSpine' = put lnsSpine' (tgtSpine',srcSpine') dV
    where dV = Set.fromList [(1,0),(2,1)]

checkSpine' = testDLens lnsSpine'

-- * Sieve

sieve_dlns :: a -> DLens [] a [] a
sieve_dlns a = ana_dlns _L f
    where f =   (((\/<~) p id_dlns id_dlns) -|-<~ id_dlns)
            .<~ coassocl_dlns
            .<~ (id_dlns -|-<~ (snd_dlns _L -|-<~ snd_dlns g) .<~ distr_dlns .<~ (id_dlns ><<~ hout_dlns))
            .<~ hout_dlns
          p _ = Left _L
          g _ = IdF a

srcSieve = [0,1,2,3]
lnsSieve :: DLens [] Int [] Int
lnsSieve = sieve_dlns (-1)
getSieve = get lnsSieve srcSieve
tgtSieve = [5,1,3]
putSieve = put lnsSieve (tgtSieve,srcSieve) dV
    where dV = Set.fromList [(1,0),(2,1)]

checkSieve = testDLens lnsSieve

-- * List concatenation

data NeList a = NeNil [a] | NeCons a (NeList a) deriving (Eq,Show)
type instance HF NeList = HFun [] :+~: HParam :*~: HId
instance Hu NeList where
    hout (NeNil l) = InlF l
    hout (NeCons x xs) = InrF $ ProdF (IdF x) xs
    hinn (InlF l) = NeNil l
    hinn (InrF (ProdF (IdF x) xs)) = NeCons x xs
instance FMonoid NeList where
    fzero = NeNil []
    fplus (NeNil xs) (NeNil ys) = NeNil (xs++ys)
    fplus (NeNil []) y = y
    fplus (NeNil xs) (NeCons y ys) = fplus (NeNil (xs++[y])) ys
    fplus x (NeNil []) = x
    fplus (NeCons x xs) y = NeCons x (fplus xs y)
instance Shapely NeList where
    traverse f = (hinn >< id) . traverse f . (hout >< id)

cat_dlns :: DLens ([] :*: []) a [] a
cat_dlns = cata_dlns nelist g .<~ ana_dlns nelist h
    where g =   hinn_dlns
            .<~ (id_dlns -|-<~ ((\/<~) p id_dlns id_dlns))
            .<~ coassocr_dlns
            .<~ (hout_dlns -|-<~ id_dlns)
          h =   (snd_dlns aux -|-<~ assocr_dlns)
            .<~ distl_dlns
            .<~ (hout_dlns ><<~ id_dlns)
          aux _ = ConsF _L
          p _ = Right _L
          nelist = ann :: Ann (Fix NeList)

srcCat = ProdF [1] [3]
tgtCat = [0,1,3,4]
lnsCat :: DLens ([] :*: []) Int [] Int
lnsCat = cat_dlns
getCat = get lnsCat srcCat
putCat = put lnsCat (tgtCat,srcCat) dV
    where dV = Set.fromList [(1,0),(2,1)]

checkCat = testDLens lnsCat

-- * Tree flatten

flatten_dlns :: DLens Tree a [] a
flatten_dlns = cata_dlns _L f
    where f = hinn_dlns .<~ (id_dlns -|-<~ id_dlns ><<~ cat_dlns)

srcFlatten = Node 1 (Node 2 Empty Empty) (Node 3 Empty Empty)
lnsFlatten :: DLens Tree Int [] Int
lnsFlatten = flatten_dlns
tgtFlatten = [0,1,2,3]
getFlatten = get lnsFlatten srcFlatten
putFlatten = put lnsFlatten (tgtFlatten,srcFlatten) dV
    where dV = Set.fromList [(1,0),(2,1),(3,2)]

checkFlatten = testDLens lnsFlatten