packages feed

references (empty) → 0.1.0.0

raw patch · 14 files changed

+1164/−0 lines, 14 filesdep +basedep +containersdep +eithersetup-changed

Dependencies added: base, containers, either, lens, mtl, template-haskell, transformers

Files

+ Control/Reference.hs view
@@ -0,0 +1,20 @@+-- | A frontend module for the Control.Reference package
+
+module Control.Reference 
+( Reference(Reference), Lens, Lens', Traversal, Traversal', LensPart, LensPart'
+, module Control.Reference.Operators
+, module Control.Reference.Predefined
+, module Control.Reference.TH.Monad
+, module Control.Reference.TH.Generate
+, module Control.Reference.TupleInstances
+) where
+
+import Control.Reference.Representation
+import Control.Reference.Operators
+import Control.Reference.Predefined
+import Control.Reference.TH.Monad
+import Control.Reference.TH.Generate
+
+-- generated classes and instances
+import Control.Reference.TH.MonadInstances
+import Control.Reference.TupleInstances
+ Control/Reference/Examples/Examples.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | A collection of random example references
+module Control.Reference.Examples.Examples where
+
+import Control.Reference
+
+import qualified Control.Lens as Lens
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad.Trans.Maybe
+import Language.Haskell.TH
+
+test1 = just .~ 3 $ Nothing
+test2 = right .~ 3 $ Right 2
+test3 = right %~ (+1) $ Right 2
+test4 = right&just %~ (+1) $ Right (Just 2)
+test5 = right & just & element 3 %~ (+1) $ Right (Just [1..10])
+test6 = both %~ (+1) $ (0 :: Int, 1 :: Int)
+test7 = both & just %~ (+1) $ (Just 0 :: Maybe Int, Nothing :: Maybe Int)
+test8 = emptyRef' & mvar %~= (+1) $ newEmptyMVar
+test9 = let isoList = iso' length (`replicate` ())
+         in isoList %~= (+1) $ [(),(),()]
+test10 = [1..10] ^? _tail' & traverse &+& _tail & _tail & traverse :: [Int]
+test11 = _tail&traverse &+& _tail&_tail&traverse %~ (+1) $ replicate 10 1 :: [Int]
+test12 = both %! print $ (0 :: Int, 1 :: Int)
+    
+data Dept = Dept { _manager :: Employee
+                 , _staff :: [Employee] 
+                 } deriving Show
+data Employee = Employee { __name :: String
+                         , __salary :: Float
+                         } deriving Show
+                         
+$(Lens.makeLenses ''Employee)
+                         
+manager :: Monad w => Lens' w Dept Dept Employee Employee
+manager = lens _manager (\b a -> a { _manager = b })
+
+staff :: Monad w => Lens' w Dept Dept [Employee] [Employee]
+staff = lens _staff (\b a -> a { _staff = b })  
+                       
+name :: (Functor w, Monad w) => Lens' w Employee Employee String String
+name = fromLens _name _name
+
+salary :: (Functor w, Monad w) => Lens' w Employee Employee Float Float
+salary = fromLens _salary _salary
+                                     
+dept = Dept (Employee "Agamemnon" 100000) [Employee "Akhilles" 30000, Employee "Menelaos" 40000]
+
+test13 = manager&salary %~ (*2) $ dept
+test14 = traverse %~ (`replicate` 'x') $ [1..10]
+
+__1 = fromLens Lens._1 Lens._1
+
+test15 = __1 %~ show $ (2,'a')
+test16 = (_1 &+& _2) & (left' &+& right') %~ ((+1) :: Int -> Int) 
+           $ (Left 3 :: Either Int Int, Right 1 :: Either Int Int)
+
+data PWrapped m a = PWrapped { _pwrap :: m a }
+
+pwrap :: Lens (PWrapped m a) (PWrapped n b) (m a) (n b)
+pwrap = lens (\(PWrapped a) -> a) (\a _ -> PWrapped a)
+
+data MWrapped a = MWrapped { _mwrap :: Maybe a }
+mwrap :: Lens (MWrapped a) (MWrapped b) (Maybe a) (Maybe b)
+mwrap = lens (\(MWrapped a) -> a) (\a _ -> MWrapped a)
+
+data Maybe' a = Just' { _fromJust' :: a }
+              | Nothing'
+              
+fromJust' :: Monad w => LensPart' w (Maybe' a) (Maybe' b) a b
+fromJust' = polyPartial (\case Just' x -> Right (x, \y -> return (Just' y))
+                               Nothing' -> Left (return Nothing'))
+    
+data Tuple a b = Tuple { _fst' :: a, _snd' :: b }
+         
+fst' :: Monad w => Lens' w (Tuple a c) (Tuple b c) a b
+fst' = lens _fst' (\b tup -> tup { _fst' = b })
+                
+test = 
+  do result <- newEmptyMVar
+     terminator <- newEmptyMVar
+     forkIO $ (result ^? mvar) >>= print >> (mvar .= ()) terminator >> return ()
+     hello <- newMVar (Just "World")
+     forkIO $ ((mvar & just & _tail & _tail) %~= ('_':) $ hello) >> return ()
+     forkIO $ ((mvar & just & element 1) .= 'u' $ hello) >> return ()
+     forkIO $ ((mvar & just) %~= ("Hello" ++) $ hello) >> return ()
+     
+     x <- runMaybeT $ hello ^? (mvar & just) 
+     mvar .= x $ result
+     terminator ^? mvar
+ Control/Reference/Examples/TH.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LiberalTypeSynonyms #-}
+
+-- | An example module that adds references for Template Haskell
+-- These references are used to create the TH functions that generate
+-- references.
+-- Because of that it does not import 'Control.Reference' frontend module.
+module Control.Reference.Examples.TH where
+
+import Language.Haskell.TH
+
+import Control.Reference.Representation
+import Control.Reference.Predefined
+
+import Control.Applicative
+
+-- | Reference all type variables inside a type
+typeVariables :: (Applicative w, Monad w) => Traversal' w Type Type Name Name
+typeVariables = fromTraversal freeTypeVariables' freeTypeVariables'
+  where freeTypeVariables' f (ForallT vars ctx t) = ForallT vars ctx <$> freeTypeVariables' f t
+        freeTypeVariables' f (AppT t1 t2) = AppT <$> freeTypeVariables' f t1 <*> freeTypeVariables' f t2
+        freeTypeVariables' f (SigT t k) = SigT <$> freeTypeVariables' f t <*> pure k
+        freeTypeVariables' f (VarT n) = VarT <$> f n
+        freeTypeVariables' _ t = pure t
+ 
+typeVariables' :: Simple Traversal Type Name
+typeVariables' = typeVariables
+ 
+-- | Reference the name of the type variable inside a type variable binder
+typeVarName :: (Applicative w, Monad w) => Lens' w TyVarBndr TyVarBndr Name Name
+typeVarName = lens (\case PlainTV n -> n; KindedTV n _ -> n) 
+                   (\n' -> \case PlainTV _ -> PlainTV n'; KindedTV _ k -> KindedTV n' k)
+
+typeVarName' :: Simple Lens TyVarBndr Name
+typeVarName' = typeVarName
+
+-- | Reference the characters of the name.
+-- If changed there is no guarantee that the created name will be unique.
+nameBaseStr :: Monad w => Lens' w Name Name String String
+nameBaseStr = iso nameBase mkName
+
+nameBaseStr' :: Simple Lens Name String
+nameBaseStr' = nameBaseStr
+
+recFields :: Monad w => Simple' w LensPart' Con [(Name, Strict, Type)]
+recFields = partial (\case (RecC _ flds) -> Just flds; _ -> Nothing) 
+                    (\flds' -> \case (RecC name _) -> RecC name flds'; con -> con)
+
+recFields' :: Simple LensPart Con [(Name, Strict, Type)]
+recFields' = recFields
+
+conFields :: Monad w => Simple' w Lens' Con [(Strict, Type)]
+conFields = lens getFlds setFlds
+  where getFlds (NormalC _ flds) = flds	
+        getFlds (RecC _ flds) = map (\(_,a,b) -> (a,b)) flds
+        getFlds (InfixC flds1 _ flds2) = [flds1, flds2]
+        getFlds (ForallC _ _ c) = getFlds c
+        
+        setFlds flds' (NormalC n _) = NormalC n flds'
+        setFlds flds' (RecC n flds) = RecC n (zipWith (\(n,_,_) (s,t) -> (n,s,t)) flds flds')
+        setFlds [fld1',fld2'] (InfixC _ n _) = InfixC fld1' n fld2'
+        setFlds flds' (ForallC bind ctx c) = ForallC bind ctx (setFlds flds' c)
+
+conFields' :: Simple Lens Con [(Strict, Type)]
+conFields' = conFields
+
+conName :: Simple Lens Con Name
+conName = lens getName setName
+  where getName (NormalC n _)   = n	
+        getName (RecC n _)      = n
+        getName (InfixC _ n _)  = n
+        getName (ForallC _ _ c) = getName c
+        
+        setName n' (NormalC _ flds)     = NormalC n' flds
+        setName n' (RecC _ flds)        = RecC n' flds
+        setName n' (InfixC fld1 _ fld2) = InfixC fld1 n' fld2
+        setName n' (ForallC bind ctx c) = ForallC bind ctx (setName n' c)
+
+funApplication :: Monad w => Simple' w Lens' Exp [Exp]
+funApplication = lens (unfoldExpr []) (\ls _ -> foldl1 AppE ls)
+  where unfoldExpr ls (AppE l r) = unfoldExpr (r : ls) l
+        unfoldExpr ls e = e : ls 
+        
+funApplication' :: Simple Lens Exp [Exp]
+funApplication' = funApplication
+
+ Control/Reference/Operators.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
+
+-- | Common operators for references
+module Control.Reference.Operators where
+
+import Control.Reference.Representation
+
+import Control.Monad.Identity
+        
+infixl 4 .~
+infixl 4 .=
+infixl 4 %~
+infixl 4 %~=
+infixl 4 %=
+infixl 4 ^.
+infixl 4 ^?
+        
+-- | Gets the referenced data
+(^.) :: s -> Reference wm Identity s t a b -> a
+a ^. l = runIdentity (a ^? l)
+
+-- | Gets the referenced data in the reader monad of the lens
+(^?) :: s -> Reference wm rm s t a b -> rm a
+a ^? l = lensGet l a
+        
+-- | Sets the referenced data (for lenses with identity writer)
+(.~) :: Reference Identity rm s t a b -> b -> (s -> t)
+l .~ v = runIdentity . (l .= v)
+
+-- | Sets the referenced data in the writer monad of the lens
+(.=) :: Monad rw => Reference rw rm s t a b -> b -> (s -> rw t)
+l .= v = lensSet l v 
+
+-- | Applies the given function on the referenced data (for lenses with identity writer)
+(%~) :: Reference Identity rm s t a b -> (a -> b) -> (s -> t)
+l %~ trf = runIdentity . lensUpdate l (return . trf)
+
+-- | Applies the given monadic function on the referenced data in the monad of the lens
+(%~=) :: Monad rw => Reference rw rm s t a b -> (a -> b) -> (s -> rw t)
+l %~= trf = lensUpdate l (return . trf)
+
+-- | Applies the given monadic function on the referenced data in the monad of the lens
+(%=) :: Reference rw rm s t a b -> (a -> rw b) -> (s -> rw t)
+l %= trf = lensUpdate l trf
+
+-- | Performs the given monadic action on referenced data
+(%!) :: Monad rw => Reference rw rm s s a a -> (a -> rw c) -> (s -> rw s)
+l %! act = lensUpdate l (\v -> act v >> return v)
+            
+-- | Composes two references. The two references should have the same writer semantics 
+-- and their reader semantics must be composable with 'MonadCompose'.
+(&) :: forall w r1 r2 s t c d a b . ( MonadCompose r1 r2 ) 
+    => Reference w r1 s t c d -> Reference w r2 c d a b
+    -> Reference w (ResultMonad r1 r2) s t a b
+(&) l1 l2 = Reference (\s -> (liftMC1 phr (lensGet l1 s)) >>= (liftMC2 phr . lensGet l2)) 
+                      (lensUpdate l1 . lensSet l2) 
+                      (lensUpdate l1 . lensUpdate l2)
+  where phr = newComposePhantom
+  
+infixl 6 &
+
+-- | Adds two references. 
+-- The references must be monomorphic, because setter needs
+-- to change the object twice.
+(&+&) :: forall w r1 r2 r12 r3 a s
+       . (Monad w, MonadPlus r3, MonadCompose r1 r2, r12 ~ ResultMonad r1 r2
+                               , MonadCompose r12 [], r3 ~ (ResultMonad r12 []))
+      => Reference w r1 s s a a -> Reference w r2 s s a a
+      -> Reference w r3 s s a a
+l1 &+& l2 = Reference (\a -> liftMC1 cf2 (liftMC1 cf1 (a ^? l1))
+                                `mplus` liftMC1 cf2 (liftMC2 cf1 (a ^? l2))) 
+                      (\v a -> (l1 .= v) a >>= l2 .= v )
+                      (\trf a -> (l1 %= trf) a >>= (l2 %= trf) )
+    where cf1 = newComposePhantom
+          cf2 = newComposePhantom :: ComposePhantom r12 []
+          
+infixl 5 &+&
+ Control/Reference/Predefined.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE LambdaCase, TupleSections #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, FunctionalDependencies, LiberalTypeSynonyms #-}
+
+-- | Predefined references.
+-- 
+-- _Naming convention_: If there is a reference @foo@ and a reference @foo'@ then 
+-- @foo'@ is the restricted version of @foo@. If @foo@ is generic in it's writer monad
+-- @foo'@ has the simplest writer monad that suffices.
+module Control.Reference.Predefined where
+
+import Control.Reference.Representation
+import Control.Reference.Operators
+import Control.Reference.TH.Tuple
+
+import Control.Concurrent.MVar
+import Data.IORef
+import Data.Map as Map
+import Data.Maybe
+import Data.Either.Combinators
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+import qualified Control.Lens as Lens
+import qualified Data.Traversable as Trav
+
+-- * Trivial references
+             
+-- | An identical lens. Accesses the context.
+simple :: Monad w => Lens' w a b a b
+simple = Reference return (const . return) id   
+     
+simple' :: Lens a b a b
+simple' = simple
+
+-- | An empty reference that do not traverse anything
+emptyRef :: (Monad w, Monad r, MonadPlus r) => SimpleRef w r s a
+emptyRef = Reference (const mzero) (const return) (const return)
+
+emptyRef' :: (Monad w) => SimpleRef w Maybe s a
+emptyRef' = emptyRef
+
+-- * Reference generators
+
+-- | Generates a traversal on any traversable
+traverse :: (Monad w, Trav.Traversable t) => Traversal' w (t a) (t b) a b
+traverse = Reference (execWriter . Trav.mapM (tell . (:[]))) 
+                     (\v -> Trav.mapM (const $ return v)) 
+                     Trav.mapM
+               
+traverse' :: (Trav.Traversable t) => Traversal (t a) (t b) a b
+traverse' = traverse
+
+
+-- | Generates a lens from a getter and a setter
+lens :: Monad w => (s -> a) -> (b -> s -> t) -> Lens' w s t a b
+lens get set = Reference (return . get) 
+                         (\b -> return . set b ) 
+                         (\f a -> f (get a) >>= \b -> return $ set b a)
+                     
+lens' :: (s -> a) -> (b -> s -> t) -> Lens s t a b
+lens' = lens
+
+-- | Creates a monomorphic partial lens
+partial :: Monad w => (s -> Maybe a) -> (a -> s -> s) -> Simple' w LensPart' s a
+partial get set = Reference get
+                            (\b -> return . set b ) 
+                            (\f a -> case get a of Just x -> f x >>= \b -> return $ set b a
+                                                   Nothing -> return a)
+                     
+partial' :: (s -> Maybe a) -> (a -> s -> s) -> Simple LensPart s a
+partial' = partial
+
+-- | Creates a polymorphic partial lense
+polyPartial :: Monad w => (s -> Either (w t) (a, b -> w t)) -> LensPart' w s t a b
+polyPartial gets = Reference (fmap fst . rightToMaybe . gets)
+                             (\b s -> case gets s of Right (_, set) -> set b
+                                                     Left t -> t ) 
+                             (\f a -> case gets a of Right (x, set) -> f x >>= set
+                                                     Left t -> t )
+                     
+polyPartial' :: (s -> Either t (a, b -> t)) -> LensPart s t a b
+polyPartial' gets = polyPartial (\s -> case gets s of Left t -> Left (return t)
+                                                      Right (v,set) -> Right (v, return . set))
+
+
+                     
+-- | Generate a reference from a simple lens from 'Control.Lens'
+fromLens :: (Functor w, Monad w) => Lens.Lens s s a a -> Lens.Lens s t a b -> Lens' w s t a b
+fromLens lm lp = Reference (\s -> return (s Lens.^. lm)) 
+                           (\b -> return . (lp Lens..~ b))
+                           lp              
+                           
+-- | Generate a reference from a simple lens from 'Control.Lens'
+fromTraversal :: (Applicative w, Monad w) 
+              => Lens.Traversal s s a a -> Lens.Traversal s t a b -> Traversal' w s t a b
+fromTraversal lm lp = Reference (\s -> s Lens.^.. lm) 
+                                (\b -> return . (lp Lens..~ b))
+                                lp
+                                                           
+-- | Filters the traversed elements with a given predicate. 
+-- Has specific versions for traversals and partial lenses.
+filtered :: (Applicative w, Monad w, MonadPlus r) 
+         => (a -> Bool) -> SimpleRef w r a a
+filtered pred = Reference (\s -> if pred s then return s else mzero)
+                          (\a s -> if pred s then return a else return s)
+                          (\f s -> if pred s then f s else return s)
+                       
+-- | Filters a traversal                       
+filteredTrav :: (Applicative w, Monad w) => (a -> Bool) -> Simple' w Traversal' a a
+filteredTrav = filtered  
+                              
+-- | Filters a partial lens                       
+filteredPartial :: (Applicative w, Monad w) => (a -> Bool) -> Simple' w LensPart' a a
+filteredPartial = filtered
+
+
+-- | Generate a lens from a pair of inverse functions
+iso :: Monad w => (a -> b) -> (b -> a) -> Simple' w Lens' a b
+iso f g = Reference (return . f) (\b _ -> return . g $ b) (\trf a -> trf (f a) >>= return . g  )      
+             
+iso' :: (a -> b) -> (b -> a) -> Simple Lens a b
+iso' = iso
+
+-- * References for simple data structures
+
+-- TODO : change to partial lens generators
+
+-- | A partial lens to access the value that may not exist
+just :: Monad w => LensPart' w (Maybe a) (Maybe b) a b
+just = Reference id (\v -> return . fmap (const v)) 
+                    (\trf -> \case Just x -> liftM Just (trf x) 
+                                   Nothing -> return Nothing)
+                              
+just' :: LensPart (Maybe a) (Maybe b) a b
+just' = just
+             
+-- | A partial lens to access the right option of an 'Either'
+right :: Monad w => LensPart' w (Either a b) (Either a c) b c
+right = Reference rightToMaybe (\v -> return . mapRight (const v)) 
+                  (\trf a -> case a of Right x -> liftM Right (trf x)
+                                       Left y -> return (Left y) )    
+                                  
+right' :: LensPart (Either a b) (Either a c) b c
+right' = right
+                  
+-- | A partial lens to access the left option of an 'Either'                  
+left :: Monad w => LensPart' w (Either a c) (Either b c) a b
+left = Reference leftToMaybe (\v -> return . mapLeft (const v)) 
+                 (\trf a -> case a of Left x -> liftM Left (trf x)
+                                      Right y -> return (Right y) )
+                                                    
+left' :: LensPart (Either a c) (Either b c) a b
+left' = left
+
+-- | Access the value that is in the left or right state of an 'Either'
+anyway :: Monad w => Lens' w (Either a a) (Either b b) a b
+anyway = Reference (\case Left a -> return a; Right a -> return a)
+                   (\b -> \case Left _ -> return (Left b); Right _ -> return (Right b))
+                   (\f -> \case Left a -> f a >>= return . Left; Right a -> f a >>= return . Right)
+
+anyway' :: Lens (Either a a) (Either b b) a b
+anyway' = anyway
+
+-- | References both elements of a tuple
+both :: Monad w => Traversal' w (a,a) (b,b) a b
+both = Reference (\(x,y) -> [x,y]) 
+                 (\v -> return . const (v,v)) 
+                 (\f (x,y) -> liftM2 (,) (f x) (f y))
+
+both' :: Traversal (a,a) (b,b) a b
+both' = both
+
+-- | References the head of a list
+_head :: Monad w => Simple' w LensPart' [a] a
+_head = Reference (\case x:_ -> Just x; _ -> Nothing) 
+                 (\a -> return . \case _:xs -> a:xs; [] -> []) 
+                 (\f -> \case x:xs -> liftM (:xs) (f x); [] -> return [])     
+    
+_head' :: Simple LensPart [a] a
+_head' = _head
+    
+-- | References the tail of a list
+_tail :: Monad w => Simple' w LensPart' [a] [a]
+_tail = Reference (\case _:xs -> Just xs; _ -> Nothing) 
+                  (\ys -> return . \case x:_ -> x:ys; [] -> []) 
+                  (\f -> \case x:xs -> liftM (x:) (f xs); [] -> return [])
+                  
+_tail' :: Simple LensPart [a] [a]
+_tail' = _tail
+                 
+-- | Lenses for given values in a data structure that is indexed by keys.
+class Association e where
+  type AssocIndex e :: *
+  type AssocElem e :: *
+  element :: Monad w => AssocIndex e -> Simple' w LensPart' e (AssocElem e)
+  
+  element' :: AssocIndex e -> Simple LensPart e (AssocElem e)
+  element' = element
+          
+instance Association [a] where          
+  type AssocIndex [a] = Int
+  type AssocElem [a] = a
+  element i = Reference (at i) (\v -> update (const (return v)))
+                        update
+    where at :: Int -> [a] -> Maybe a
+          at n xs | n < 0 =  Nothing
+          at _ []         =  Nothing
+          at 0 (x:_)      =  Just x
+          at n (_:xs)     =  at (n-1) xs
+          
+          update :: Monad w => (a -> w a) -> [a] -> w [a]
+          update f ls = let (before,rest) = splitAt i ls
+                         in case rest of [] -> return before
+                                         (x:xs) -> f x >>= \fx -> return $ before ++ fx : xs
+  
+instance Ord k => Association (Map k v) where
+  type AssocIndex (Map k v) = k
+  type AssocElem (Map k v) = v
+  element k = Reference (Map.lookup k) (\v -> return . insert k v) 
+                        (\trf m -> case Map.lookup k m of Just x -> return (insert k x m)
+                                                          Nothing -> return m)
+
+-- * Stateful references
+                                                          
+-- | Access a value inside an MVar. Writing should only be used for initial 
+-- assignment or parts of the program will block infinitely. Reads and updates are done in sequence,
+-- always using consistent data.
+
+-- TODO: could mvar be polymorphic? (withMVar is OK for update, but coercion is needed for set)
+mvar :: SimpleRef IO IO (MVar a) a
+mvar = Reference readMVar
+                 (\newVal mv -> putMVar mv newVal >> return mv)     
+                 (\trf mv -> modifyMVar_ mv trf >> return mv)     
+
+-- | Access the current value inside an MVar. Never blocks.
+mvarNow :: SimpleRef IO (MaybeT IO) (MVar a) a
+mvarNow = Reference (MaybeT . tryTakeMVar)
+                    (\newVal mv -> tryPutMVar mv newVal >> return mv)     
+                    (\trf mv -> tryTakeMVar mv >>= \case Just x -> trf x >>= tryPutMVar mv >> return mv
+                                                         Nothing -> return mv)  
+                 
+-- | Access the value of an IORef.
+
+-- TODO: could ioref be polymorphic?
+ioref :: SimpleRef IO IO (IORef a) a
+ioref = Reference readIORef (\v ior -> atomicWriteIORef ior v >> return ior) 
+                  (\trf ior -> readIORef ior >>= trf >>= writeIORef ior >> return ior) 
+  
+-- | Access the state inside a state monad (from any context).
+state :: SimpleRef (State s) (State s) a s
+state = Reference (const get) (\a s -> put a >> return s) 
+                  (\trf s -> (get >>= trf >> return s))   
+ Control/Reference/Representation.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}
+
+-- | This module declares the representation and basic classes of references.
+module Control.Reference.Representation where
+
+import Control.Monad.Identity (Identity(..))
+import Control.Monad.List (ListT(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Maybe (maybeToList)
+
+-- | A reference is an accessor to a part or different view of some data. 
+-- The reference, unlike the lens has a separate getter, setter and updater.
+--
+-- == Reference laws
+--
+-- As the references are generalizations of lenses, they should conform to the lens laws:
+--
+-- 1) You get back what you put in:
+--
+-- @
+-- 'lensSet' l a s >>= 'lensGet' l ≡ a
+-- @
+--
+-- 2) Putting back what you got doesn't change anything:
+--
+-- @
+-- 'lensGet' l a >>= \b -> 'lensSet' l b s ≡ s
+-- @
+--
+-- 3) Setting twice is the same as setting once:
+--
+-- @
+-- 'lensSet' l a s >>= 'lensSet' l b ≡ 'lensSet' l b s
+-- @
+--
+-- But because they are more powerful than lenses, they should be more responsible.
+-- 
+-- 4) Updating something is the same as getting and then setting:
+--
+-- @
+-- 'lensGet' l a >>= f >>= \b -> 'lensSet' l b s ≡ lensUpdate b s
+-- @
+--
+-- == Type arguments
+--   ['wm'] Writer monad, controls how the value can be reassembled when the part is changed. 
+--          Usually 'Identity'.
+--   ['rm'] Reader monad. Controls how part of the value can be accessed. 
+--          See 'Lens', 'LensPart' and 'Traversal'
+--   ['s'] The original context.
+--   ['t'] The context after replacing the accessed part to something of type 'b'.
+--   ['a'] The accessed part.
+--   ['b'] The accessed part can be changed to this.
+
+-- TODO: represent isomorphisms with a type parameter
+-- TODO: indexed traversals
+data Reference wm rm s t a b
+  = Reference { lensGet :: s -> rm a                    -- ^ Getter for the lens
+              , lensSet :: b -> s -> wm t               -- ^ Setter for the lens
+              , lensUpdate :: (a -> wm b) -> s -> wm t  -- ^ Updater for the lens. 
+                                                        -- Handles monadic update functions.
+              }
+              
+-- | A monomorph 'Lens', 'Traversal', 'LensPart', etc... 
+-- Setting or updating does not change the type of the base.
+type Simple t s a = t s s a a
+
+-- | A monomorph 'Lens'', 'Traversal'', 'LensPart'', etc... 
+-- Setting or updating does not change the type of the base.
+-- Needs @LiberalTypeSynonyms@ language extension
+type Simple' (w :: * -> *) t s a = t w s s a a
+type SimpleRef wm rm s a = Reference wm rm s s a a
+              
+-- | The Lens is a reference that represents an 1 to 1 relationship.
+type Lens = Reference Identity Identity
+type Lens' w = Reference w Identity
+
+-- | The Traversal is a reference that represents an 1 to any relationship.
+type Traversal = Reference Identity []
+type Traversal' w = Reference w []
+
+-- | The parital lens is a reference that represents an 1 to 0..1 relationship.
+type LensPart = Reference Identity Maybe
+type LensPart' w = Reference w Maybe
+
+ 
+-- | Combines the functionality of two monads into one. Has two functions that lift a 
+-- monadic action into the result monad.
+class Monad (ResultMonad m1 m2) => MonadCompose (m1 :: * -> *) (m2 :: * -> *) where
+  -- | The type of the result monad
+  type ResultMonad m1 m2 :: * -> *
+  -- | A phantom type to help coercions. Coercions are often needed when only one of
+  -- the lifting functions are used.
+  data ComposePhantom m1 m2 :: *
+  -- | Creates a new phantom variable to state that two liftings result in the same type.
+  newComposePhantom :: ComposePhantom m1 m2
+  -- | Lifts the first monad into the result monad.
+  liftMC1 :: ComposePhantom m1 m2 -> m1 a -> ResultMonad m1 m2 a
+  -- | Lifts the second monad into the result monad.
+  liftMC2 :: ComposePhantom m1 m2 -> m2 a -> ResultMonad m1 m2 a
+  
+-- | States that 'm1' can be represented with 'm2'
+class MonadSubsume (m1 :: * -> *) (m2 :: * -> *) where
+  -- | Lifts the first monad into the second.
+  liftMS :: m1 a -> m2 a
+  
+ Control/Reference/TH/Generate.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | This module can be used to generate references for record fields.
+-- If the field surely exists, a 'Lens' will be generated.
+-- If the field may not exist, it will be a 'LensPart'.
+--
+-- If the name of the field starts with "_", the name of the field will be the same with "_" removed. 
+-- If not, the reference name will be the field name with "_" added te the start.
+--
+-- The following code sample:
+--
+-- > data Maybe' a = Just' { _fromJust' :: a }
+-- >               | Nothing'
+-- > $(makeReferences ''Maybe)
+-- >
+-- > data Tuple a b = Tuple { _fst' :: a, _snd' :: b }
+-- > $(makeReferences ''Tuple)
+--
+-- Is equivalent to:
+-- 
+-- > data Maybe' a = Just' { _fromJust' :: a }
+-- >               | Nothing'
+-- >               
+-- > fromJust' :: Monad w => LensPart' w (Maybe' a) (Maybe' b) a b
+-- > fromJust' = polyPartial (\case Just' x -> Right (x, \y -> return (Just' y))
+-- >                                Nothing' -> Left (return Nothing'))
+-- >
+-- > data Tuple a b = Tuple { _fst' :: a, _snd' :: b }
+-- > fst' :: Monad w => Lens' w (Tuple a c) (Tuple b c) a b
+-- > fst' = lens _fst' (\b tup -> tup { _fst' = b })
+-- > snd' :: Monad w => Lens' w (Tuple a c) (Tuple a d) c d
+-- > snd' = lens _snd' (\b tup -> tup { _snd' = b })
+--
+module Control.Reference.TH.Generate (makeReferences) where
+
+import Language.Haskell.TH
+import qualified Data.Map as M
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Writer
+import Control.Monad.Trans
+import Control.Monad.Trans.State
+import Control.Applicative
+import Debug.Trace
+
+import Control.Reference.Representation
+import Control.Reference.Predefined
+import Control.Reference.Operators
+import Control.Reference.Examples.TH
+import Control.Reference.TH.MonadInstances
+import Control.Reference.TupleInstances
+
+-- | Creates references for fields of a data structure.
+makeReferences :: Name -> Q [Dec]
+makeReferences n 
+  = do inf <- reify n
+       res <- case inf of
+                TyConI decl -> case newtypeToData decl of
+                  DataD ctx tyConName args cons _ -> case cons of
+                    [con] -> makeLensesForCon tyConName args con 
+                    _ -> liftM concat $ mapM (makePartialLensesForCon tyConName args cons) cons
+                  _ -> fail "makeReferences: Unsupported data type"
+                _ -> fail "makeReferences: Expected the name of a data type or newtype"
+                
+       -- runIO $ putStrLn $ pprint res
+       return res
+
+makeLensesForCon :: Name -> [TyVarBndr] -> Con -> Q [Dec]
+makeLensesForCon tyName tyVars (RecC conName conFields) 
+  = liftM concat $ mapM (\(n, _, t) -> createLensForField tyName tyVars conName n t) conFields
+makeLensesForCon _ _ _ = return []
+             
+createLensForField :: Name -> [TyVarBndr] -> Name -> Name -> Type -> Q [Dec]
+createLensForField typName typArgs conName fldName fldTyp 
+  = do lTyp <- referenceType (ConT ''Lens') typName typArgs fldTyp  
+       lensBody <- genLensBody
+       return [ SigD lensName lTyp
+              , ValD (VarP lensName) (NormalB $ lensBody) []
+              ] 
+   where lensName = refName fldName
+   
+         genLensBody :: Q Exp
+         genLensBody 
+           = do setVar <- newName "b"
+                origVar <- newName "s"
+                return $ VarE 'lens 
+                           `AppE` VarE fldName 
+                           `AppE` LamE [VarP setVar, AsP origVar (RecP conName [])] 
+                                       (RecUpdE (VarE origVar) [(fldName,VarE setVar)])
+           
+           
+makePartialLensesForCon :: Name -> [TyVarBndr] -> [Con] -> Con -> Q [Dec]
+makePartialLensesForCon tyName tyVars cons (RecC conName conFields) 
+  = liftM concat $ mapM (\(n, _, t) -> createPartialLensForField tyName tyVars conName cons n t) conFields
+makePartialLensesForCon _ _ _ _ = return []
+           
+createPartialLensForField :: Name -> [TyVarBndr] -> Name -> [Con] -> Name -> Type -> Q [Dec]
+createPartialLensForField  typName typArgs conName cons fldName fldTyp 
+  = do lTyp <- referenceType (ConT ''LensPart') typName typArgs fldTyp  
+       lensBody <- genLensBody
+       return [ SigD lensName lTyp
+              , ValD (VarP lensName) (NormalB $ lensBody) []
+              ] 
+   where lensName = refName fldName
+   
+         genLensBody :: Q Exp
+         genLensBody 
+           = do matchesWithField <- mapM matchWithField consWithField 
+                matchesWithoutField <- mapM matchWithoutField consWithoutField
+                name <- newName "x"
+                return $ VarE 'polyPartial 
+                           `AppE` LamE [VarP name] (CaseE (VarE name) ( matchesWithField ++ matchesWithoutField ))
+                           
+         (consWithField, consWithoutField) 
+           = partition (hasField fldName) cons
+           
+         matchWithField :: Con -> Q Match
+         matchWithField con 
+           = do (bind, rebuild, vars) <- bindAndRebuild con
+                setVar <- newName "b"
+                let Just bindInd = fieldIndex fldName con
+                    bindRight 
+                      = ConE 'Right 
+                          `AppE` TupE [ VarE (vars !! bindInd)
+                                      , LamE [VarP setVar] 
+                                             (VarE 'return `AppE` 
+                                               (funApplication' & element (bindInd+1)
+                                                 .~ VarE setVar $ rebuild)) 
+                                      ]
+                return $ Match bind (NormalB bindRight) []
+                         
+         matchWithoutField :: Con -> Q Match
+         matchWithoutField con 
+           = do (bind, rebuild, _) <- bindAndRebuild con
+                return $ Match bind (NormalB (ConE 'Left `AppE` (VarE 'return `AppE` rebuild))) []
+                                       
+           
+referenceType :: Type -> Name -> [TyVarBndr] -> Type -> Q Type
+referenceType refType name args fldTyp 
+  = do w <- newName "w"
+       let argTypes = args ^? traverse&typeVarName'
+       (fldTyp',mapping) <- makePoly argTypes fldTyp
+       let args' = traverse&typeVarName' %~ (\a -> fromMaybe a (mapping ^? element' a)) $ args
+       return $ ForallT (map PlainTV (w : M.elems mapping ++ argTypes)) [ClassP ''Monad [VarT w]] 
+                        (refType `AppT` VarT w 
+                                 `AppT` addTypeArgs name args 
+                                 `AppT` addTypeArgs name args' 
+                                 `AppT` fldTyp 
+                                 `AppT` fldTyp') 
+           
+-- | Creates a new field type with changing the type variables that are bound outside
+makePoly :: [Name] -> Type -> Q (Type, M.Map Name Name)
+makePoly typArgs fldTyp 
+  = runStateT (typVarsBounded %= updateName $ fldTyp) M.empty           
+  where typVarsBounded = typeVariables & filteredTrav (`elem` typArgs)
+        updateName :: Name -> StateT (M.Map Name Name) Q Name
+        updateName name = do name' <- lift (newName (nameBase name ++ "'")) 
+                             modify (M.insert name name')
+                             return name'
+
+
+-- | Dictates what reference names should be generated from field names
+refName :: Name -> Name
+refName = nameBaseStr %~ \case '_':xs -> xs; xs -> '_':xs
+
+-- * Helper functions 
+
+hasField :: Name -> Con -> Bool
+hasField n = not . null . (^? recFields' & traverse & _1 & filteredTrav (==n))
+         
+fieldIndex :: Name -> Con -> Maybe Int
+fieldIndex n con = (con ^? recFields') >>= findIndex (\f -> (f ^. _1') == n)
+         
+-- | Creates a type from applying binded type variables to a type function
+addTypeArgs :: Name -> [TyVarBndr] -> Type
+addTypeArgs n = foldl AppT (ConT n) 
+                  . map (VarT . (^. typeVarName'))
+ 
+newtypeToData :: Dec -> Dec
+newtypeToData (NewtypeD ctx name tvars con derives) 
+  = DataD ctx name tvars [con] derives
+newtypeToData d = d
+
+bindAndRebuild :: Con -> Q (Pat, Exp, [Name])
+bindAndRebuild con 
+  = do let name = con ^. conName
+           fields = con ^. conFields'
+       bindVars <- replicateM (length fields) (newName "fld")
+       return ( ConP name (map VarP bindVars)
+              , -- TODO : use funApplication isomorphisms
+                foldl AppE (ConE name) (map VarE bindVars)
+              , bindVars
+              )
+
+ Control/Reference/TH/Monad.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
+{-# LANGUAGE LambdaCase, DoAndIfThenElse #-}
+
+-- | A module for making connections between different monads.
+module Control.Reference.TH.Monad (makeMonadRepr) where
+
+import Control.Reference.Representation
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+
+import Debug.Trace
+import Data.Char
+import Data.List
+import Data.Maybe
+import Language.Haskell.TH
+
+class ToQType t where
+  toQType :: t -> Q Type
+  
+instance ToQType Type where 
+  toQType = return    
+instance ToQType (Q Type) where 
+  toQType = id  
+instance ToQType Name where 
+  toQType = return . ConT  
+  
+class ToQExp t where
+  toQExp :: t -> Q Exp
+  
+instance ToQExp (Q Exp) where 
+  toQExp = id  
+instance ToQExp Name where 
+  toQExp = return . VarE
+
+type IGState m a = StateT InstanceGenState m a
+  
+data InstanceGenState = IGS { subsumeInsts :: [(Type, Type)]
+                            , composeInsts :: [(Type, Type)]            
+                            } deriving Show
+   
+-- | Creates 'MonadSubsume' and 'MonadCompose' instances that can be inferred from a single subsume 
+-- connection and all instances declared so far.
+makeMonadRepr :: (ToQType t1, ToQType t2, ToQExp e) 
+              => t1 -> t2 -> e -> Q [Dec]
+makeMonadRepr m1' m2' e'
+  = do t1 <- toQType m1'; t2 <- toQType m2'; e <- toQExp e' 
+       ClassI _ subsumeInstances <- reify ''MonadSubsume
+       let subsumes = map (\(InstanceD _ (AppT (AppT _ below) above) _) -> (below, above))
+                          subsumeInstances
+       ClassI _ composeInstances <- reify ''MonadCompose
+       let composes = map (\(InstanceD _ (AppT (AppT _ m1) m2) _) -> (m1, m2)) composeInstances
+       res <- evalStateT (makeMonadRepr' t1 t2 e) (IGS subsumes composes)
+       -- runIO $ mapM (putStrLn . pprint) res
+       return res
+
+
+makeMonadRepr' :: Type -> Type -> Exp -> IGState Q [Dec]
+makeMonadRepr' t1 t2 e
+  = do reflexiveSubs <- sequence [ generateSubsume t1 t1 (\_ -> VarE 'id)
+                                 , generateSubsume t2 t2 (\_ -> VarE 'id) 
+                                 , generateCompose t1 t1 t1 (\_ -> VarE 'id) (\_ -> VarE 'id)
+                                 , generateCompose t2 t2 t2 (\_ -> VarE 'id) (\_ -> VarE 'id)
+                                 ]
+       
+       (_      , belowM1) <- collectedSubsumes t1
+       (aboveM2, belowM2) <- collectedSubsumes t2
+       subs <- sequence [ generateSubsume bm am (\x -> liftMSCasted t2 am x @.@ e @.@ liftMSCasted bm t1 x) 
+                          | Below bm <- belowM1, Above am <- aboveM2 ]
+       compBelows  <- sequence [ generateComposes bm1 bm2 t2 (\x -> e @.@ liftMSCasted bm1 t1 x) 
+                                                             (\x -> liftMSCasted bm2 t2 x) 
+                                  | Below bm1 <- belowM1, Below bm2 <- belowM2 ]
+       compThrough <- sequence [ generateComposes bm1 am2 am2 (\x -> liftMSCasted t2 am2 x @.@ e @.@ liftMSCasted bm1 t1 x) 
+                                                              (\_ -> VarE 'id) 
+                                  | Below bm1 <- belowM1, Above am2 <- aboveM2 ]
+       return ((catMaybes $ reflexiveSubs ++ subs) ++ concat (compBelows ++ compThrough))
+
+newtype Above = Above Type deriving (Show)
+newtype Below = Below Type deriving (Show)
+       
+collectedSubsumes :: Type -> IGState Q ([Above], [Below])
+collectedSubsumes t
+  = gets subsumeInsts >>= return . foldl collect ([],[])
+  where collect (above,below) (tb,ta) 
+          = ( if t == tb then Above ta : above else above
+            , if t == ta then Below tb : below else below )
+       
+liftMSCasted :: Type -> Type -> Name -> Exp
+liftMSCasted t1 t2 n 
+  = VarE 'liftMS `SigE` (ForallT [PlainTV n] [] $ ArrowT `AppT` (t1 `AppT` VarT n) `AppT` (t2 `AppT` VarT n))
+       
+(@.@) :: Exp -> Exp -> Exp
+a @.@ b = InfixE (Just a) (VarE (mkName ".")) (Just b)
+     
+generateComposes :: Type -> Type -> Type -> (Name -> Exp) -> (Name -> Exp) -> IGState Q [Dec]
+generateComposes t1 t2 t3 e1 e2 = do c1 <- generateCompose t1 t2 t3 e1 e2
+                                     c2 <- generateCompose t2 t1 t3 e2 e1
+                                     return $ catMaybes [c1,c2]
+     
+generateCompose :: Type -> Type -> Type -> (Name -> Exp) -> (Name -> Exp) -> IGState Q (Maybe Dec)
+generateCompose m1 m2 m3 e1 e2
+  = do composes <- gets composeInsts
+       if not ((m1,m2) `elem` composes) then
+         do dataName <- lift $ newName ("ComposePhantom_" ++ filter isAlphaNum (show m1) 
+                                                   ++ "_" ++ filter isAlphaNum (show m2))
+            modify $ \st -> st { composeInsts = (m1,m2) : composeInsts st }
+            x <- lift (newName "x")
+            return $ Just $ 
+              InstanceD [] ((ConT ''MonadCompose) `AppT` m1 `AppT` m2)
+                        [ generateTypeSynonym
+                        , DataInstD [] ''ComposePhantom [m1,m2] [NormalC dataName []] []
+                        , ValD (VarP 'newComposePhantom) (NormalB (ConE dataName)) []
+                        , FunD 'liftMC1 [Clause [WildP] (NormalB (e1 x)) []]
+                        , FunD 'liftMC2 [Clause [WildP] (NormalB (e2 x)) []]
+                        ]
+       else return Nothing
+    where 
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
+    generateTypeSynonym = TySynInstD ''ResultMonad (TySynEqn [m1, m2] m3)
+#else
+    generateTypeSynonym = TySynInstD ''ResultMonad [m1, m2] m3
+#endif     
+     
+generateSubsume :: Type -> Type -> (Name -> Exp) -> IGState Q (Maybe Dec)
+generateSubsume m1 m2 e
+  = do subsumes <- gets subsumeInsts
+       if isNothing (find (== (m1,m2)) subsumes) then 
+         do modify $ \st -> st { subsumeInsts = (m1,m2) : subsumeInsts st }
+            x <- lift (newName "x")
+            return $ Just $ 
+              InstanceD [] ((ConT ''MonadSubsume) `AppT` m1 `AppT` m2)
+                        [ FunD 'liftMS [Clause [] (NormalB (e x)) []] ]
+       else return Nothing
+
+
+ Control/Reference/TH/MonadInstances.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies, RankNTypes #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+
+-- | A basic set of instances derived using "Control.Reference.TH.Monad".
+-- 
+-- == Structure defined
+--
+-- @
+--            'ListT' 'IO'
+--           /         \\
+--         []       'Control.Monad.Trans.Maybe.MaybeT' 'IO'
+--         |      /     |
+--       'Maybe'         'IO'
+--            \\       /
+--            'Control.Monad.Trans.Identity.Identity'
+-- @
+module Control.Reference.TH.MonadInstances () where
+
+import Control.Reference.TH.Monad
+
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe as Trans
+import Control.Monad.Trans.List as Trans
+import Data.Maybe
+import Language.Haskell.TH as TH
+
+$(makeMonadRepr ''Identity          ''Maybe                     [e| return . runIdentity |])
+$(makeMonadRepr ''Identity          ''IO                        [e| return . runIdentity |])
+$(makeMonadRepr ''Maybe             [t| MaybeT IO |]            [e| MaybeT . return |])
+$(makeMonadRepr ''IO                [t| MaybeT IO |]            [e| MaybeT . liftM Just |])
+$(makeMonadRepr ''Maybe             TH.ListT                    [e| maybeToList |])
+$(makeMonadRepr TH.ListT            [t| Trans.ListT IO |]       [e| Trans.ListT . return |])
+$(makeMonadRepr ''IO                [t| Trans.ListT IO |]       [e| Trans.ListT . liftM (:[]) |])
+$(makeMonadRepr [t| MaybeT IO |]    [t| Trans.ListT IO |]       [e| Trans.ListT . liftM maybeToList . runMaybeT |])
+ Control/Reference/TH/Tuple.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}
+-- | A module for making connections between different monads.
+module Control.Reference.TH.Tuple (makeTupleRefs) where
+
+import Language.Haskell.TH
+import Control.Monad
+
+import Control.Reference.Representation
+
+-- | Creates @_1@ ... @_n@ classes, and instances for tuples up to m
+makeTupleRefs :: Int -> Int -> Q [Dec]
+makeTupleRefs n m 
+  = liftM2 (++) (genClass `mapM` [0..(n-1)]) 
+                (genInstance `mapM` [ (x, y) | x <- [0..(n-1)], y <- [(max 2 (x+1))..m] ])
+      -- >>= runIO . putStrLn . pprint >> return []
+             
+     
+
+genClass :: Int -> Q Dec
+genClass i 
+  = do s <- newName "s"
+       t <- newName "t"
+       a <- newName "a"
+       b <- newName "b1"
+       w <- newName "w"
+       let tvars = map PlainTV [s,t,a,b]
+       return $ ClassD [] (mkName ("Lens_" ++ show (i+1))) tvars
+                       [ FunDep [s] [a], FunDep [t] [b]
+                       , FunDep [a,t] [s], FunDep [b,s] [t]] 
+                       [ SigD normalLens 
+                              ( ForallT [PlainTV w] 
+                                        [ClassP ''Monad [VarT w]] 
+                                        (foldl AppT (ConT ''Lens') (map VarT [w,s,t,a,b])) )
+                       , SigD restrictedLens 
+                              (foldl AppT (ConT ''Lens) (map VarT [s,t,a,b]))
+                       , ValD (VarP restrictedLens) (NormalB $ VarE normalLens) []                
+                       ]    
+  where normalLens = mkName ("_" ++ show (i+1))
+        restrictedLens = mkName ("_" ++ show (i+1) ++ "'")
+        
+
+genInstance :: (Int,Int) -> Q Dec
+genInstance (n,m)
+  = do names <- replicateM m (newName "a")
+       name <- newName "b2"
+       genBody <- generateBody
+       return $ InstanceD [] (ConT (mkName ("Lens_" ++ show (n+1))) 
+                                `AppT` foldl AppT (TupleT m) (map VarT names)
+                                `AppT` foldl AppT (TupleT m) (map VarT (replace n name names))
+                                `AppT` VarT (names !! n)
+                                `AppT` VarT name
+                             ) 
+                             [ ValD (VarP (mkName ("_" ++ show (n+1)))) 
+                                    (NormalB genBody) [] ]
+
+  where generateBody :: Q Exp
+        generateBody 
+          = do names <- replicateM m (newName "a")
+               name <- newName "b3"
+               trf <- newName "trf"
+               return $ ConE 'Reference 
+                          `AppE` LamE [TupP (map VarP names)] 
+                                      (VarE 'return `AppE` VarE (names !! n))
+                          `AppE` LamE [VarP name, TupP (map VarP names)] 
+                                      (VarE 'return `AppE` TupE (map VarE (replace n name names)))
+                          `AppE` LamE [VarP trf, TupP (map VarP names)] 
+                                      (VarE 'liftM 
+                                        `AppE` LamE [VarP name] (TupE (map VarE (replace n name names))) 
+                                        `AppE` (VarE trf `AppE` VarE (names !! n)))
+                                    
+replace :: Int -> a -> [a] -> [a]
+replace i e ls 
+  = let (before,after) = splitAt i ls 
+     in case after of [] -> error $ "replace : Index " ++ show i ++ " is not found." 
+                      _:rest -> before ++ e : rest
+ 
+ Control/Reference/TupleInstances.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+
+-- | A module where tuple classes and instances are created up to 16-tuple using 'makeTupleRefs'.
+-- The number of classes and instances can be changed by hiding import from this module
+-- and calling 'makeTupleRefs' in an other module.
+module Control.Reference.TupleInstances where
+
+import Control.Reference.TH.Tuple
+
+$(makeTupleRefs 16 16)
+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Boldizsar Nemeth
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Boldizsar Nemeth nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ references.cabal view
@@ -0,0 +1,39 @@+-- Initial references.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                references
+version:             0.1.0.0
+synopsis:            Generalization of lenses, folds and traversals for haskell
+description:         Similar to lenses, references provide access to part of a structure or a different
+                     view on the structure. References are considered to be a generalization of those,
+                     but the come with a different representation. The main purpose of references is to 
+                     have accessors that can cooperate with monads, especially IO.
+homepage:            https://github.com/lazac/references
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+-- copyright:           
+category:            Control
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Control.Reference
+                     , Control.Reference.TH.MonadInstances
+                     , Control.Reference.TH.Monad
+                     , Control.Reference.TH.Generate
+                     , Control.Reference.TH.Tuple
+                     , Control.Reference.Examples.TH
+                     , Control.Reference.Representation
+                     , Control.Reference.Operators
+                     , Control.Reference.Predefined
+                     , Control.Reference.TupleInstances
+  other-modules:       Control.Reference.Examples.Examples
+  build-depends:       base ==4.7.*
+                     , mtl ==2.2.*
+                     , transformers ==0.4.*
+                     , containers ==0.5.*
+                     , either ==4.3.*
+                     , lens ==4.2.*
+                     , template-haskell ==2.9.*