references 0.2.0.0 → 0.2.1.0
raw patch · 8 files changed
+306/−264 lines, 8 files
Files
- Control/Reference.hs +2/−2
- Control/Reference/Predefined.hs +1/−1
- Control/Reference/Representation.hs +12/−4
- Control/Reference/TH/Generate.hs +0/−210
- Control/Reference/TH/Records.hs +210/−0
- Control/Reference/TH/Tuple.hs +73/−43
- Control/Reference/TupleInstances.hs +1/−1
- references.cabal +7/−3
Control/Reference.hs view
@@ -3,7 +3,7 @@ module Control.Reference ( module Control.Reference.InternalInterface , module Control.Reference.TH.Monad-, module Control.Reference.TH.Generate+, module Control.Reference.TH.Records , module Control.Reference.TH.MonadInstances , module Control.Reference.TupleInstances ) where@@ -12,7 +12,7 @@ -- generator modules import Control.Reference.TH.Monad-import Control.Reference.TH.Generate+import Control.Reference.TH.Records -- generated classes and instances import Control.Reference.TH.MonadInstances
Control/Reference/Predefined.hs view
@@ -7,7 +7,7 @@ #endif --- | Predefined references for commonly used data structures. +-- | Predefined references for commonly used data structures and reference generators. -- -- When defining lenses one should use the more general types. For instance 'Lens' instead of the more strict 'Lens''. This way references with different @m1@ and @m2@ monads can be combined if there is a monad @m'@ for @MMorph m1 m'@ and @MMorph m2 m'@. module Control.Reference.Predefined where
Control/Reference/Representation.hs view
@@ -1,7 +1,8 @@ {- LANGUAGE CPP -} {-# LANGUAGE KindSignatures, TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances + , MultiParamTypeClasses, TypeFamilies #-} -- | This module declares the representation and basic classes of references. @@ -21,6 +22,7 @@ import Control.Monad.Identity (Identity(..)) import Control.Monad.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Control (MonadBaseControl) -- | A reference is an accessor to a part or different view of some data. -- The referenc has a separate getter, setter and updater. In some cases, @@ -172,9 +174,15 @@ -- * References for 'IO' +class ( MMorph IO w, MMorph IO r + , MonadBaseControl IO w, MonadBaseControl IO r ) => IOMonads w r where + +instance ( MMorph IO w, MMorph IO r + , MonadBaseControl IO w, MonadBaseControl IO r ) => IOMonads w r where + -- | A reference that can access mutable data. type IOLens s t a b - = forall w r . ( RefMonads w r, MMorph IO w, MMorph IO r ) + = forall w r . ( RefMonads w r, IOMonads w r ) => Reference w r s t a b -- | A reference that must access mutable data that is available in the context. @@ -182,14 +190,14 @@ -- | A reference that can access mutable data that may not exist in the context. type IOPartial s t a b - = forall w r . (RefMonads w r, MMorph IO w, MonadPlus r, MMorph IO r, MMorph Maybe r ) + = forall w r . (RefMonads w r, IOMonads w r, MonadPlus r, MMorph Maybe r ) => Reference w r s t a b -- | A reference that must access mutable data that may not exist in the context. type IOPartial' = Reference IO (MaybeT IO) type IOTraversal s t a b - = forall w r . ( RefMonads w r, MMorph IO w, MonadPlus r, MMorph IO r, MMorph [] r ) + = forall w r . ( RefMonads w r, IOMonads w r, MonadPlus r, MMorph [] r ) => Reference w r s t a b -- | A reference that can access mutable data that is available in a number of
− Control/Reference/TH/Generate.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE LambdaCase, TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - -{-| -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 'Partial' lens. - -It will have the maximum amount of polymorphism it can create. - -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' :: 'Partial' (Maybe' a) (Maybe' b) a b -fromJust' = 'partial' (\case Just' x -> Right (x, \y -> return (Just' y)) - Nothing' -> Left (return Nothing')) - -data Tuple a b = Tuple { _fst' :: a, _snd' :: b } -fst' :: 'Lens' (Tuple a c) (Tuple b c) a b -fst' = 'lens' _fst' (\b tup -> tup { _fst' = b }) -snd' :: 'Lens' (Tuple a c) (Tuple a d) c d -snd' = 'lens' _snd' (\b tup -> tup { _snd' = b }) -@ --} -module Control.Reference.TH.Generate (makeReferences, debugTH) where - -import Language.Haskell.TH hiding (ListT) -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.List -import Control.Monad.Trans.State -import Control.Applicative - -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 - --- | Shows the generated declarations instead of using them. -debugTH :: Q [Dec] -> Q [Dec] -debugTH d = d >>= runIO . putStrLn . pprint >> return [] - --- | Creates references for fields of a data structure. -makeReferences :: Name -> Q [Dec] -makeReferences n - = do inf <- reify n - 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" - - -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 ''Partial) 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 'partial - `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] - (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` rebuild)) [] - - -referenceType :: Type -> Name -> [TyVarBndr] -> Type -> Q Type -referenceType refType name args fldTyp - = do 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 (sort (nub (M.elems mapping ++ argTypes)))) [] - (refType `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 :: Simple (StateTraversal' (M.Map Name Name) Q) Type Name - typVarsBounded = typeVariables & filtered (`elem` typArgs) - 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 & filtered (==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 - ) - -instance MMorph [] (ListT (StateT s Q)) where - morph = ListT . return - -instance Monad m => MMorph (StateT s m) (ListT (StateT s m)) where - morph = lift
+ Control/Reference/TH/Records.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +{-| +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 'Partial' lens. + +It will have the maximum amount of polymorphism it can create. + +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' :: 'Partial' (Maybe' a) (Maybe' b) a b +fromJust' = 'partial' (\case Just' x -> Right (x, \y -> return (Just' y)) + Nothing' -> Left (return Nothing')) + +data Tuple a b = Tuple { _fst' :: a, _snd' :: b } +fst' :: 'Lens' (Tuple a c) (Tuple b c) a b +fst' = 'lens' _fst' (\b tup -> tup { _fst' = b }) +snd' :: 'Lens' (Tuple a c) (Tuple a d) c d +snd' = 'lens' _snd' (\b tup -> tup { _snd' = b }) +@ +-} +module Control.Reference.TH.Records (makeReferences, debugTH) where + +import Language.Haskell.TH hiding (ListT) +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.List +import Control.Monad.Trans.State +import Control.Applicative + +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 + +-- | Shows the generated declarations instead of using them. +debugTH :: Q [Dec] -> Q [Dec] +debugTH d = d >>= runIO . putStrLn . pprint >> return [] + +-- | Creates references for fields of a data structure. +makeReferences :: Name -> Q [Dec] +makeReferences n + = do inf <- reify n + 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" + + +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 ''Partial) 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 'partial + `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] + (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` rebuild)) [] + + +referenceType :: Type -> Name -> [TyVarBndr] -> Type -> Q Type +referenceType refType name args fldTyp + = do 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 (sort (nub (M.elems mapping ++ argTypes)))) [] + (refType `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 :: Simple (StateTraversal' (M.Map Name Name) Q) Type Name + typVarsBounded = typeVariables & filtered (`elem` typArgs) + 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 & filtered (==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 + ) + +instance MMorph [] (ListT (StateT s Q)) where + morph = ListT . return + +instance Monad m => MMorph (StateT s m) (ListT (StateT s m)) where + morph = lift
Control/Reference/TH/Tuple.hs view
@@ -1,66 +1,96 @@ {-# LANGUAGE TemplateHaskell #-}--- | A module for making connections between different monads.-module Control.Reference.TH.Tuple (makeTupleRefs) where+-- | A module for creating lenses to fields of simple, tuple data structures +-- like pairs, triplets, and so on.+module Control.Reference.TH.Tuple (TupleConf(..), hsTupConf, makeTupleRefs) where import Language.Haskell.TH import Control.Monad+import Control.Applicative+import Data.Maybe -import Control.Reference.Representation+import Control.Reference.InternalInterface --- | 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 []- - +-- | Creates @Lens_1@ ... @Lens_n@ classes, and instances for tuples up to 'm'.+-- +-- Classes and instances look like the following:+-- +-- @+-- class Lens_1 s t a b | s -> a, t -> b+-- , a t -> s, b s -> t where +-- _1 :: Lens s t a b+--+-- instance Lens_1 (a,b) (a',b) a a' where +-- _1 = lens (\(a,b) -> a) (\a' (a,b) -> (a',b))+-- @+--+makeTupleRefs :: TupleConf -> Int -> Int -> Q [Dec]+makeTupleRefs conf n m + = (++) <$> (catMaybes <$> genClass `mapM` [0..(n-1)]) + <*> (genInstance conf + `mapM` [ (x, y) | x <- [0..(n-1)]+ , y <- [(max 2 (x+1))..m] ]) -genClass :: Int -> Q Dec+genClass :: Int -> Q (Maybe Dec) genClass i - = do s <- newName "s"- t <- newName "t"- a <- newName "a"- b <- newName "b1"- 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 [] [] (foldl AppT (ConT ''Lens) (map VarT [s,t,a,b])) ) - ] - where normalLens = mkName ("_" ++ show (i+1))- + = do declared <- classDeclared i+ if declared then return Nothing+ else Just <$> genClass' i+ where genClass' i = + do s <- newName "s"+ t <- newName "t"+ a <- newName "a"+ b <- newName "b1"+ let tvars = map PlainTV [s,t,a,b]+ return $ ClassD [] (lensClass i) tvars+ [ FunDep [s] [a], FunDep [t] [b]+ , FunDep [a,t] [s], FunDep [b,s] [t]] + [ SigD (lensFun i) + (foldl AppT (ConT ''Lens) (map VarT [s,t,a,b])) + ] -genInstance :: (Int,Int) -> Q Dec-genInstance (n,m)+lensClass i = mkName ("Lens_" ++ show (i+1))+lensFun i = mkName ("_" ++ show (i+1))+ +classDeclared :: Int -> Q Bool +classDeclared i = isJust <$> lookupTypeName (nameBase $ lensClass i)++genInstance :: TupleConf -> (Int,Int) -> Q Dec+genInstance (TupleConf typGen patGen expGen) (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))+ return $ InstanceD [] (ConT (lensClass n) + `AppT` typGen names+ `AppT` typGen (replace n name names) `AppT` VarT (names !! n) `AppT` VarT name ) - [ ValD (VarP (mkName ("_" ++ show (n+1)))) + [ ValD (VarP (lensFun n) ) (NormalB genBody) [] ] where generateBody :: Q Exp- generateBody + generateBody = do names <- replicateM m (newName "a") name <- newName "b3"- trf <- newName "trf"- return $ VarE '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)))- + return $ VarE 'lens + `AppE` LamE [patGen names] + (VarE (names !! n))+ `AppE` LamE [VarP name, patGen names] + (expGen (replace n name names))++-- | A tuple configuration is a scheme for tuple-like data structures.+data TupleConf = TupleConf { tupleType :: [Name] -> Type+ , tuplePattern :: [Name] -> Pat+ , tupleExpr :: [Name] -> Exp+ }+ +-- | Generates the normal haskell tuples (@(a,b), (a,b,c), (a,b,c,d)@) +hsTupConf + = TupleConf (\names -> foldl AppT (TupleT (length names)) . map VarT $ names) + (TupP . map VarP) + (TupE . map VarE)+ +-- | Utility function to replace the N'th element of a list replace :: Int -> a -> [a] -> [a] replace i e ls = let (before,after) = splitAt i ls
Control/Reference/TupleInstances.hs view
@@ -8,5 +8,5 @@ import Control.Reference.TH.Tuple -$(makeTupleRefs 16 16)+$(makeTupleRefs hsTupConf 16 16)
references.cabal view
@@ -1,5 +1,5 @@ name: references -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Generalization of lenses, folds and traversals to handle monads and addition. description: References can read, write or update parts of the data. They are first-class values, can be passed in functions, transformed, combined. @@ -34,10 +34,14 @@ New references can be created in several ways: . * From getter, setter and updater, using the @reference@ function. - * From getter and setter, using one of the simplified functions (@lens@, @simplePartial@, @partial@, ...). + . + * From getter and setter, using one of the simplified functions (@lens@, @simplePartial@, @partial@, ...). + . * Using the `Data.Traversal` instance on a datatype to generate a traversal of each element. + . * Using lenses from `Control.Lens` package. There are a lot of packages defining lenses, folds and traversals for various data structures, so it is very useful that all of them can simply be converted into a reference. + . * Generating references for newly defined records using the `makeReferences` Template Haskell function. . @@ -57,7 +61,7 @@ exposed-modules: Control.Reference , Control.Reference.TH.MonadInstances , Control.Reference.TH.Monad - , Control.Reference.TH.Generate + , Control.Reference.TH.Records , Control.Reference.TH.Tuple , Control.Reference.Examples.TH , Control.Reference.Representation