references 0.2.1.1 → 0.2.1.2
raw patch · 11 files changed
+585/−141 lines, 11 filesdep +arraydep +text
Dependencies added: array, text
Files
- Control/Reference.hs +2/−0
- Control/Reference/Examples/TH.hs +65/−9
- Control/Reference/InternalInterface.hs +4/−1
- Control/Reference/Operators.hs +50/−10
- Control/Reference/Predefined.hs +117/−66
- Control/Reference/Predefined/Containers.hs +152/−0
- Control/Reference/Predefined/Containers/Tree.hs +19/−0
- Control/Reference/Representation.hs +144/−42
- Control/Reference/TH/MonadInstances.hs +20/−1
- Control/Reference/TH/Records.hs +6/−11
- references.cabal +6/−1
Control/Reference.hs view
@@ -2,6 +2,7 @@ module Control.Reference ( module Control.Reference.InternalInterface+, module Control.Reference.Predefined.Containers.Tree , module Control.Reference.TH.Monad , module Control.Reference.TH.Records , module Control.Reference.TH.MonadInstances@@ -9,6 +10,7 @@ ) where import Control.Reference.InternalInterface+import Control.Reference.Predefined.Containers.Tree -- generator modules import Control.Reference.TH.Monad
Control/Reference/Examples/TH.hs view
@@ -6,24 +6,46 @@ module Control.Reference.Examples.TH where import Control.Reference.InternalInterface +import Control.Reference.TupleInstances import Control.Applicative import Language.Haskell.TH -- | Reference all type variables inside a type -typeVariables :: Simple Traversal Type Name -typeVariables = fromTraversal 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 +typeVariableNames :: Simple Traversal Type Name +typeVariableNames = typeVariables & typeVar + +-- | Reference the name of the type variable +typeVar :: Simple Partial Type Name +typeVar = partial ( \case VarT n -> Right (n, \n' -> VarT n') + other -> Left other ) + +-- | Reference all type variables inside a type +typeVariables :: Simple Traversal Type Type +typeVariables = fromTraversal typeVariables' + where typeVariables' f (ForallT vars ctx t) = ForallT vars ctx <$> typeVariables' f t + typeVariables' f (AppT t1 t2) = AppT <$> typeVariables' f t1 <*> typeVariables' f t2 + typeVariables' f (SigT t k) = SigT <$> typeVariables' f t <*> pure k + typeVariables' f tv@(VarT _) = f tv + typeVariables' _ t = pure t + +-- | Reference all type variables not binded by a forall +freeTypeVariables :: Simple Traversal Type Type +freeTypeVariables = fromTraversal (freeTypeVariables' []) + where freeTypeVariables' bn f (ForallT vars ctx t) + = ForallT vars ctx <$> freeTypeVariables' (bn ++ (vars ^* traverse&typeVarName)) f t + freeTypeVariables' bn f (AppT t1 t2) = AppT <$> freeTypeVariables' bn f t1 <*> freeTypeVariables' bn f t2 + freeTypeVariables' bn f (SigT t k) = SigT <$> freeTypeVariables' bn f t <*> pure k + freeTypeVariables' bn f tv@(VarT n) = if n `elem` bn then pure tv else f tv + freeTypeVariables' bn _ t = pure t -- | Reference the name of the type variable inside a type variable binder typeVarName :: Simple Lens TyVarBndr Name typeVarName = lens (\case PlainTV n -> n; KindedTV n _ -> n) (\n' -> \case PlainTV _ -> PlainTV n'; KindedTV _ k -> KindedTV n' k) + + -- | Reference the characters of the name. -- If changed there is no guarantee that the created name will be unique. nameBaseStr :: Simple Lens Name String @@ -47,6 +69,10 @@ setFlds [fld1',fld2'] (InfixC _ n _) = InfixC fld1' n fld2' setFlds flds' (ForallC bind ctx c) = ForallC bind ctx (setFlds flds' c) +-- | Reference types of fields +conTypes :: Simple Traversal Con Type +conTypes = conFields & traverse & _2 + -- | Reference the name of the constructor conName :: Simple Lens Con Name conName = lens getName setName @@ -62,9 +88,39 @@ -- | Access a function application as a list of expressions with the function application -- at the head of the list and the arguments on it's tail. -funApplication :: Simple Lens Exp [Exp] -funApplication = lens (unfoldExpr []) (\ls _ -> foldl1 AppE ls) +funApplication :: Simple Iso Exp [Exp] +funApplication = iso (unfoldExpr []) (foldl1 AppE) where unfoldExpr ls (AppE l r) = unfoldExpr (r : ls) l unfoldExpr ls e = e : ls +-- | Accesses the name of the defined object. Does not return name in signatures. +definedName :: Simple Partial Dec Name +definedName + = partial (\case FunD n c -> Right (n, \n' -> FunD n' c) + ValD (VarP n) b w -> Right (n, \n' -> ValD (VarP n') b w) + DataD c n tv con d -> Right (n, \n' -> DataD c n' tv con d) + NewtypeD c n tv con d -> Right (n, \n' -> NewtypeD c n' tv con d) + TySynD n tv t -> Right (n, \n' -> TySynD n' tv t) + ClassD c n tv fd f -> Right (n, \n' -> ClassD c n' tv fd f) + FamilyD fl n tv k -> Right (n, \n' -> FamilyD fl n' tv k) + other -> Left other) +-- | Accesses the constructors of a data or newtype definition. +-- After changing the definition becames a newtype if there is only one constructor. +definedConstructors :: Simple Partial Dec [Con] +definedConstructors + = partial (\case DataD c n tv con d -> Right (con, \con' -> createConOrNewtype c n tv con' d) + NewtypeD c n tv con d -> Right ([con], \con' -> createConOrNewtype c n tv con' d) + other -> Left other) + where createConOrNewtype c n tv [con] d = NewtypeD c n tv con d + createConOrNewtype c n tv cons d = DataD c n tv cons d + +-- | Accesses the type variables of a definition +definedTypeArgs :: Simple Partial Dec [TyVarBndr] +definedTypeArgs + = partial (\case DataD c n tv con d -> Right (tv, \tv' -> DataD c n tv' con d) + NewtypeD c n tv con d -> Right (tv, \tv' -> NewtypeD c n tv' con d) + TySynD n tv t -> Right (tv, \tv' -> TySynD n tv' t) + ClassD c n tv fd f -> Right (tv, \tv' -> ClassD c n tv' fd f) + FamilyD fl n tv k -> Right (tv, \tv' -> FamilyD fl n tv' k) + other -> Left other)
Control/Reference/InternalInterface.hs view
@@ -8,7 +8,8 @@ -- For creating a new interface with different generated elements, use this internal interface. -- module Control.Reference.InternalInterface - ( Simple, Reference, reference, referenceWithClose + ( Simple, Reference, bireference, reference, referenceWithClose + , Iso , Lens, Partial, Traversal , Lens', Partial', Traversal' , IOLens, IOPartial, IOTraversal @@ -20,8 +21,10 @@ , MMorph(..) , module Control.Reference.Operators , module Control.Reference.Predefined + , module Control.Reference.Predefined.Containers ) where import Control.Reference.Representation import Control.Reference.Operators import Control.Reference.Predefined +import Control.Reference.Predefined.Containers
Control/Reference/Operators.hs view
@@ -22,16 +22,27 @@ -- module Control.Reference.Operators where + import Control.Reference.Representation + +import Control.Applicative import Control.Monad.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.List + +-- | Flips a reference to the other direction +turn :: Reference w r w' r' s t a b -> Reference w' r' w r a b s t +turn (Reference refGet refSet refUpdate refGet' refSet' refUpdate') + = (Reference refGet' refSet' refUpdate' refGet refSet refUpdate) + +review :: Reference MU MU Identity Identity s t a b -> a -> s +review r a = a ^. turn r -- * Getters -- | Gets the referenced data in the monad of the lens. -- Does not bind the type of the writer monad, so the reference must have its type disambiguated. -(^#) :: RefMonads w r => s -> Reference w r s t a b -> r a +(^#) :: RefMonads w r => s -> Reference w r w' r' s t a b -> r a a ^# l = refGet l return a infixl 4 ^# @@ -70,7 +81,7 @@ -- | Sets the referenced data to the given pure value in the monad of the reference. -- -- Does not bind the type of the reader monad, so the reference must have its type disambiguated. -(#=) :: Reference w r s t a b -> b -> s -> w t +(#=) :: Reference w r w' r' s t a b -> b -> s -> w t l #= v = refSet l v infixl 4 #= @@ -109,7 +120,7 @@ -- | Applies the given monadic function on the referenced data in the monad of the lens. -- -- Does not bind the type of the reader monad, so the reference must have its type disambiguated. -(#~) :: Reference w r s t a b -> (a -> w b) -> s -> w t +(#~) :: Reference w r w' r' s t a b -> (a -> w b) -> s -> w t l #~ trf = refUpdate l trf infixl 4 #~ @@ -148,7 +159,7 @@ -- | Applies the given pure function on the referenced data in the monad of the lens. -- -- Does not bind the type of the reader monad, so the reference must have its type disambiguated. -(#-) :: Monad w => Reference w r s t a b -> (a -> b) -> s -> w t +(#-) :: Monad w => Reference w r w' r' s t a b -> (a -> b) -> s -> w t l #- trf = l #~ return . trf infixl 4 #- @@ -187,7 +198,7 @@ -- | Performs the given monadic action on referenced data while giving back the original data. -- -- Does not bind the type of the reader monad, so the reference must have its type disambiguated. -(#|) :: Monad w => Reference w r s s a a -> (a -> w x) -> s -> w s +(#|) :: Monad w => Reference w r w' r' s s a a -> (a -> w x) -> s -> w s l #| act = l #~ (\v -> act v >> return v) infixl 4 #| @@ -214,11 +225,14 @@ -- than the reference @r&p@ will access @c@ inside @a@. -- -- Composition is associative: @ (r&p)&q = r&(p&q) @ -(&) :: (Monad w, Monad r) => Reference w r s t c d -> Reference w r c d a b - -> Reference w r s t a b +(&) :: (Monad w, Monad r) => Reference w r w' r' s t c d -> Reference w r w' r' c d a b + -> Reference w r w' r' s t a b (&) l1 l2 = Reference (refGet l1 . refGet l2) (refUpdate l1 . refSet l2) (refUpdate l1 . refUpdate l2) + (refGet' l2 . refGet' l1) + (refUpdate' l2 . refSet' l1) + (refUpdate' l2 . refUpdate' l1) infixl 6 & -- | Adds two references. @@ -233,11 +247,37 @@ -- Addition is commutative only if we do not consider the order of the results from a get, -- or the order in which monadic actions are performed. -- -(&+&) :: (Monad w, MonadPlus r, MMorph [] r) - => Reference w r s s a a -> Reference w r s s a a - -> Reference w r s s a a +(&+&) :: (RefMonads w r, RefMonads w' r', MonadPlus r, MonadPlus r', MMorph [] r) + => Reference w r w' r' s s a a -> Reference w r w' r' s s a a + -> Reference w r w' r' s s a a l1 &+& l2 = Reference (\f a -> refGet l1 f a `mplus` refGet l2 f a) (\v -> refSet l1 v >=> refSet l2 v ) (\trf -> refUpdate l1 trf >=> refUpdate l2 trf ) + (\f a -> refGet' l1 f a `mplus` refGet' l2 f a) + (\v -> refSet' l1 v >=> refSet' l2 v ) + (\trf -> refUpdate' l1 trf + >=> refUpdate' l2 trf ) infixl 5 &+& + +-- | Pack two references in parallel. + +(&|&) :: (RefMonads m m') + => Reference m m m' m' s t a b -> Reference m m m' m' s' t' a' b' + -> Reference m m m' m' (s, s') (t, t') (a, a') (b, b') +r1 &|& r2 = Reference (\f (s1,s2) -> ((,) <$> refGet r1 return s1 <*> refGet r2 return s2) >>= f) + (\(b1,b2) (s1,s2) -> (,) <$> refSet r1 b1 s1 <*> refSet r2 b2 s2) + (\f (s1,s2) -> do a1 <- refGet r1 return s1 + a2 <- refGet r2 return s2 + t1 <- refUpdate r1 (liftM fst . flip (curry f) a2) s1 + t2 <- refUpdate r2 (liftM snd . curry f a1) s2 + return (t1, t2) ) + (\f (s1,s2) -> ((,) <$> refGet' r1 return s1 <*> refGet' r2 return s2) >>= f) + (\(b1,b2) (s1,s2) -> (,) <$> refSet' r1 b1 s1 <*> refSet' r2 b2 s2) + (\f (s1,s2) -> do a1 <- refGet' r1 return s1 + a2 <- refGet' r2 return s2 + t1 <- refUpdate' r1 (liftM fst . flip (curry f) a2) s1 + t2 <- refUpdate' r2 (liftM snd . curry f a1) s2 + return (t1, t2) ) + +infixl 5 &|&
Control/Reference/Predefined.hs view
@@ -13,19 +13,24 @@ module Control.Reference.Predefined where import Control.Reference.Representation +import Control.Reference.Operators import Control.Applicative import Control.Monad import qualified Data.Traversable as Trav +import Data.Ratio +import qualified Data.Text as Text +import Data.Complex import Control.Monad.Trans.Control import Control.Monad.Identity import Control.Monad.Writer import Control.Monad.State +import Control.Monad.ST import Control.Concurrent.MVar.Lifted import Control.Concurrent.Chan import Data.IORef -import Data.Map as Map import Data.Either.Combinators +import Data.STRef -- * Trivial references @@ -53,8 +58,14 @@ Trav.mapM -- | Generate a lens from a pair of inverse functions -iso :: (a -> b) -> (b -> a) -> Lens a a b b -iso f g = reference (return . f) (\b _ -> return . g $ b) (\trf a -> trf (f a) >>= return . g ) +iso :: (a -> b) -> (b -> a) -> Simple Iso a b +iso f g = bireference (return . f) (\b _ -> return . g $ b) (\trf a -> trf (f a) >>= return . g ) + (return . g) (\a _ -> return . f $ a) (\trf b -> trf (g b) >>= return . f ) + +iso' :: (a -> b) -> (a' -> b') -> (b -> a) -> (b' -> a') -> Iso a a' b b' +iso' f f' g g' + = bireference (return . f) (\b _ -> return . g' $ b) (\trf a -> trf (f a) >>= return . g' ) + (return . g) (\a _ -> return . f' $ a) (\trf b -> trf (g b) >>= return . f' ) -- | Generates a lens from a getter and a setter lens :: (s -> a) -> (b -> s -> t) -> Lens s t a b @@ -62,22 +73,34 @@ (\b -> return . set b ) (\f a -> f (get a) >>= \b -> return $ set b a) --- | Creates a monomorphic partial lense +-- | Creates a polymorphic partial lense +-- +-- @Either t a@ is used instead of @Maybe a@ to permit the types of 's' and 't' to differ. partial :: (s -> Either t (a, b -> t)) -> Partial s t a b partial access = reference - (\s -> case access s of Left _ -> morph Nothing - Right (a,_) -> return a) - (\b s -> case access s of Left t -> return t - Right (_,set) -> return (set b)) - (\f s -> case access s of Left t -> return t - Right (a,set) -> f a >>= return . set) - + (either (const $ morph Nothing) (return . fst) . access) + (\b -> return . either id (($b) . snd) . access) + (\f -> either return (\(a,set) -> f a >>= return . set) . access) + +-- | Creates a polymorphic partial lens that can be turned to give a total lens +prism :: (a -> s) -> (b -> t) -> (s -> Either t a) -> (t -> Maybe b) -> Prism s t a b +prism back back' access access' + = bireference (either (const $ morph Nothing) return . access) + (\b -> return . either id (const $ (back' b)) . access) + (\f -> either return (f >=> return . back') . access) + (return . back) + (\t _ -> morph $ access' t) + (\f a -> f (back a) >>= morph . access') + +-- | Creates a monomorphic partial lens that can be turned to give a total lens +simplePrism :: (a -> s) -> (s -> Maybe a) -> Prism s s a a +simplePrism back access = prism back back (\s -> maybe (Left s) Right (access s)) access + -- | Creates a simple partial lens simplePartial :: (s -> Maybe (a, a -> s)) -> Partial s s a a simplePartial access - = partial (\s -> case access s of Just x -> Right x - Nothing -> Left s) + = partial (\s -> maybe (Left s) Right (access s)) -- | Clones a lens from "Control.Lens" @@ -102,19 +125,16 @@ -- * References for simple data structures -- | A partial lens to access the value that may not exist -just :: Partial (Maybe a) (Maybe b) a b -just = partial (\case Just x -> Right (x, Just) - Nothing -> Left Nothing) - +just :: Prism (Maybe a) (Maybe b) a b +just = prism Just Just (maybe (Left Nothing) Right) id + -- | A partial lens to access the right option of an 'Either' -right :: Partial (Either a b) (Either a c) b c -right = partial (\case Right x -> Right (x, Right) - Left a -> Left (Left a)) - +right :: Prism (Either a b) (Either a c) b c +right = prism Right Right (either (Left . Left) Right) rightToMaybe + -- | A partial lens to access the left option of an 'Either' -left :: Partial (Either a c) (Either b c) a b -left = partial (\case Left a -> Right (a, Left) - Right r -> Left (Right r)) +left :: Prism (Either a c) (Either b c) a b +left = prism Left Left (either Right (Left . Right)) leftToMaybe -- | Access the value that is in the left or right state of an 'Either' anyway :: Lens (Either a a) (Either b b) a b @@ -124,48 +144,70 @@ -- | References both elements of a tuple both :: Traversal (a,a) (b,b) a b -both = reference (\(x,y) -> morph [x,y]) - (\v -> return . const (v,v)) - (\f (x,y) -> (,) <$> f x <*> f y) +both = reference (\(x,y) -> morph [x,y]) + (\v -> return . const (v,v)) + (\f (x,y) -> (,) <$> f x <*> f y) -- | References the head of a list -_head :: Simple Partial [a] a -_head = simplePartial (\case [] -> Nothing; x:xs -> Just (x,(:xs))) +atHead :: Simple Lens [a] (Maybe a) +atHead = lens (\case [] -> Nothing; x:_ -> Just x) + (\case Nothing -> drop 1; + Just v -> \case [] -> [v] + _:xs -> v:xs) + +-- | References the element at the head of the list +headElem :: Simple Partial [a] a +headElem = atHead & just -- | References the tail of a list _tail :: Simple Partial [a] [a] _tail = simplePartial (\case [] -> Nothing; x:xs -> Just (xs,(x:))) + +-- | References a suffix of a list +dropped :: Int -> Simple Partial [a] [a] +dropped 0 = self +dropped i = _tail & dropped (i-1) + +-- | Views a list as an optinal pair +view :: Iso [a] [b] (Maybe (a,[a])) (Maybe (b,[b])) +view = iso' to to from from + where to :: [x] -> Maybe (x,[x]) + to [] = Nothing + to (x:xs) = Just (x,xs) + from :: Maybe (x,[x]) -> [x] + from Nothing = [] + from (Just (x,xs)) = x:xs + +-- | An isomorphism between the list and text representation of a string +text :: Simple Iso String Text.Text +text = iso Text.pack Text.unpack + +-- | Accesses the reversed version of a list +-- +-- > 'turn' reversed == reversed +reversed :: Iso [a] [b] [a] [b] +reversed = iso' reverse reverse reverse reverse + +-- | Accesses the numerator of a ratio +_numerator :: Integral a => Simple Lens (Ratio a) a +_numerator = lens numerator (\num' r -> num' % denominator r) + +-- | Accesses the denominator of a ratio +_denominator :: Integral a => Simple Lens (Ratio a) a +_denominator = lens denominator (\denom' r -> numerator r % denom') --- | Lenses for given values in a data structure that is indexed by keys. -class Association e where - type AssocIndex e :: * - type AssocElem e :: * - element :: AssocIndex e -> Simple Partial e (AssocElem e) - -instance Association [a] where - type AssocIndex [a] = Int - type AssocElem [a] = a - element i = reference (morph . at i) (\v -> upd (const (return v))) - upd - where at :: Int -> [a] -> Maybe a - at n _ | n < 0 = Nothing - at _ [] = Nothing - at 0 (x:_) = Just x - at n (_:xs) = at (n-1) xs - - upd :: Monad w => (a -> w a) -> [a] -> w [a] - upd 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 (morph . Map.lookup k) - (\v -> return . insert k v) - (\trf m -> case Map.lookup k m of Just x -> trf x >>= \x' -> return (insert k x' m) - Nothing -> return m) +-- | Accesses the real part of a complex number +_realPart :: RealFloat a => Simple Lens (Complex a) a +_realPart = lens realPart (\real' c -> real' :+ imagPart c) +-- | Accesses the imaginary part of a complex number +_imagPart :: RealFloat a => Simple Lens (Complex a) a +_imagPart = lens imagPart (\imag' c -> realPart c :+ imag') + +-- | Accesses the polar representation of a complex number +_polar :: RealFloat a => Simple Lens (Complex a) (a, a) +_polar = iso polar (uncurry mkPolar) + -- * Stateful references -- | A dummy object to interact with the user through the console. @@ -187,14 +229,15 @@ -- value, one may block and can corrupt the following updates. -- -- Reads and updates are done in sequence, always using consistent data. -mvar :: ( Functor w, Applicative w, Monad w, MMorph IO w, MonadBaseControl IO w - , Functor r, Applicative r, Monad r, MMorph IO r) - => Simple (Reference w r) (MVar a) a -mvar = reference (morph . (readMVar :: MVar a -> IO a)) - (\newVal mv -> do empty <- isEmptyMVar mv - when empty (swapMVar mv newVal >> return ()) - return mv) - (\trf mv -> modifyMVarMasked_ mv trf >> return mv) +mvar :: Simple IOLens (MVar a) a +mvar = rawReference + (flip withMVarMasked) + (\newVal mv -> do empty <- isEmptyMVar mv + if empty then putMVar mv newVal + else swapMVar mv newVal >> return () + return mv) + (\trf mv -> modifyMVarMasked_ mv trf >> return mv) + (\_ _ -> MU) (\_ _ -> MU) (\_ _ -> MU) chan :: Simple IOLens (Chan a) a @@ -216,3 +259,11 @@ (\trf s -> (morph get' >>= trf >> return s)) where put' = put :: s -> StateT s m () get' = get :: StateT s m s + +-- | Access the value inside an 'STRef' +stRef :: Simple (STLens s) (STRef s a) a +stRef = reference (morph . readSTRef) + (\newVal ref -> morph $ writeSTRef ref newVal >> return ref) + (\trf ref -> morph (readSTRef ref) >>= trf + >>= morph . writeSTRef ref >> return ref) +
+ Control/Reference/Predefined/Containers.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-}+module Control.Reference.Predefined.Containers where++import Control.Reference.Representation+import Control.Reference.Predefined+import Control.Reference.Operators+ +import Data.Map as Map+import qualified Data.Array as Arr+import qualified Data.Set as Set+import qualified Data.IntSet as IS+import qualified Data.IntMap as IM+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+ +-- | Lenses for given values in a data structure that is indexed by keys.+class Association e where+ type AssocIndex e :: *+ type AssocElem e :: *+ + element :: AssocIndex e -> Simple Partial e (AssocElem e)+ +instance Association [a] where + type AssocIndex [a] = Int+ type AssocElem [a] = a+ element i = reference (morph . at i) (\v -> upd (const (return v))) upd+ where at :: Int -> [a] -> Maybe a+ at n _ | n < 0 = Nothing+ at _ [] = Nothing+ at 0 (x:_) = Just x+ at n (_:xs) = at (n-1) xs+ + upd :: Monad w => (a -> w a) -> [a] -> w [a]+ upd f ls = let (before,rest) = splitAt i ls+ in case rest of [] -> return before+ (x:xs) -> f x >>= \fx -> return $ before ++ fx : xs+ +instance Arr.Ix i => Association (Arr.Array i a) where + type AssocIndex (Arr.Array i a) = i+ type AssocElem (Arr.Array i a) = a+ element i = reference (morph . at) (\v -> upd (const (return v))) upd+ where at :: (Arr.Array i a) -> Maybe a+ at arr | Arr.inRange (Arr.bounds arr) i+ = Just (arr Arr.! i)+ | otherwise = Nothing+ upd :: Monad w => (a -> w a) -> Arr.Array i a -> w (Arr.Array i a)+ upd f arr | Arr.inRange (Arr.bounds arr) i+ = f (arr Arr.! i) >>= \v -> return (arr Arr.// [(i,v)])+ | otherwise = return arr++instance Association (Seq.Seq a) where + type AssocIndex (Seq.Seq a) = Int+ type AssocElem (Seq.Seq a) = a+ element i = reference (morph . at i) (\v -> upd (const (return v)))+ upd+ where at :: Int -> Seq.Seq a -> Maybe a+ at n s = case Seq.viewl (snd (Seq.splitAt i s)) of + Seq.EmptyL -> Nothing+ v Seq.:< _ -> Just v+ + upd :: Monad w => (a -> w a) -> Seq.Seq a -> w (Seq.Seq a)+ upd f s = let (before,rest) = Seq.splitAt i s+ in case Seq.viewl rest of + Seq.EmptyL -> return before+ x Seq.:< xs -> f x >>= \fx -> return $ before Seq.>< (fx Seq.<| xs)+ +instance Association Text.Text where+ type AssocIndex Text.Text = Int+ type AssocElem Text.Text = Char+ element i = reference (morph . at) (\v -> upd (const (return v)))+ upd+ where at :: Text.Text -> Maybe Char+ at s | Text.length s > i = Just (Text.index s i)+ | otherwise = Nothing+ + upd :: Monad w => (Char -> w Char) -> Text.Text -> w Text.Text+ upd f s = let (before,rest) = Text.splitAt i s+ in case Text.uncons rest of + Nothing -> return before+ Just (x,xs) -> f x >>= \fx -> return $ Text.append before (Text.cons fx xs)+ +class Association e => Mapping e where+ at :: AssocIndex e -> Simple Lens e (Maybe (AssocElem e))+ +instance Eq a => Association (a -> Maybe b) where + type AssocIndex (a -> Maybe b) = a+ type AssocElem (a -> Maybe b) = b+ element i = simplePartial (\f -> case f i of Just x -> Just (x, \b k -> if i == k then Just b else f k)+ Nothing -> Nothing) + +instance Eq a => Mapping (a -> Maybe b) where+ at i = lens ($ i) (\b f k -> if i == k then b else f k)+ +instance Ord k => Association (Map k v) where+ type AssocIndex (Map k v) = k+ type AssocElem (Map k v) = v+ element k = reference (morph . Map.lookup k)+ (\v -> return . Map.insert k v) + (\trf m -> case Map.lookup k m of Just x -> trf x >>= \x' -> return (Map.insert k x' m)+ Nothing -> return m)++instance Ord k => Mapping (Map k v) where+ at k = reference (return . (^? element k))+ (\v -> return . Map.alter (const v) k) + (\f m -> f (Map.lookup k m) >>=+ return . maybe (Map.delete k m) + (\fx -> Map.insert k fx m)) + +instance Association (IM.IntMap v) where+ type AssocIndex (IM.IntMap v) = Int+ type AssocElem (IM.IntMap v) = v+ element k = reference (morph . IM.lookup k)+ (\v -> return . IM.insert k v) + (\trf m -> case IM.lookup k m of + Just x -> trf x >>= \x' -> return (IM.insert k x' m)+ Nothing -> return m)++instance Mapping (IM.IntMap v) where+ at k = reference (return . (^? element k))+ (\v -> return . IM.alter (const v) k) + (\f m -> f (IM.lookup k m) >>=+ return . maybe (IM.delete k m) + (\fx -> IM.insert k fx m)) + +-- | Containers that can be used as a set, inserting and removing elements+class SetLike e where+ type SetElem e :: *+ contains :: (SetElem e) -> Simple Lens e Bool+ +instance Ord v => SetLike (Set.Set v) where+ type SetElem (Set.Set v) = v+ contains e + = reference + (return . Set.member e)+ (\v -> return . if v then Set.insert e+ else Set.delete e)+ (\trf s -> trf (Set.member e s) >>= return . \case + True -> Set.insert e s+ False -> Set.delete e s)+ +instance SetLike IS.IntSet where+ type SetElem IS.IntSet = Int+ contains e + = reference + (return . IS.member e)+ (\v -> return . if v then IS.insert e+ else IS.delete e)+ (\trf s -> trf (IS.member e s) >>= return . \case + True -> IS.insert e s+ False -> IS.delete e s)
+ Control/Reference/Predefined/Containers/Tree.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TypeFamilies #-}+module Control.Reference.Predefined.Containers.Tree where++import Control.Reference.InternalInterface+import Control.Reference.TupleInstances++import qualified Data.Tree as Tree++instance Association (Tree.Tree v) where+ type AssocIndex (Tree.Tree v) = [Int]+ type AssocElem (Tree.Tree v) = v+ element is = simplePartial (accessNode is)+ where accessNode [] (Tree.Node lab for) + = Just (lab, \lab' -> Tree.Node lab' for)+ accessNode (i:is) (Tree.Node lab for)+ = case for ^? element i of+ Just subFor -> just&_2 ?- (\upd -> Tree.Node lab . (\v -> element i ?= v $ for) . upd)+ $ accessNode is subFor+ Nothing -> Nothing
Control/Reference/Representation.hs view
@@ -1,4 +1,3 @@-{- LANGUAGE CPP -} {-# LANGUAGE KindSignatures, TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances @@ -8,12 +7,9 @@ -- | This module declares the representation and basic classes of references. -- -- This module should not be imported directly. - --- TODO: references that can be flipped (isomorphisms and prisms) --- TODO: indexed traversals --- TODO: read-only and write-only references module Control.Reference.Representation where +import Data.Maybe (maybeToList) import Control.Applicative import Control.Monad import Control.Monad.Base @@ -22,6 +18,7 @@ import Control.Monad.Identity (Identity(..)) import Control.Monad.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.ST (ST) import Control.Monad.Trans.Control (MonadBaseControl) -- | A reference is an accessor to a part or different view of some data. @@ -65,6 +62,8 @@ -- See differences between 'Lens', 'IOLens' and 'StateLens' -- ['r'] Reader monad. Controls how part of the value can be asked. -- See differences between 'Lens', 'Partial' and 'Traversal' +-- [@w'@] Backward writer monad. See 'turn' +-- [@r'@] Backward reader monad. See 'turn' -- ['s'] The type of the original context. -- ['t'] The after replacing the accessed part to something of type 'b' -- the type of the context changes to 't'. @@ -76,7 +75,7 @@ -- The reader monad usually have more information (@MMorph 'w' 'r'@). -- -data Reference w r s t a b +data Reference w r w' r' s t a b = Reference { refGet :: forall x . (a -> r x) -> s -> r x -- ^ Getter for the lens. Takes a monadic function and runs it -- on the accessed value. This is necessary to run actions after @@ -85,17 +84,47 @@ -- ^ Setter for the lens , refUpdate :: (a -> w b) -> s -> w t -- ^ Updater for the lens. Handles monadic update functions. + , refGet' :: forall x . (s -> r' x) -> a -> r' x + , refSet' :: t -> a -> w' b + , refUpdate' :: (s -> w' t) -> a -> w' b } +-- Creates a two-way reference +bireference :: (RefMonads w r, RefMonads w' r') + => (s -> r a) -- ^ Getter + -> (b -> s -> w t) -- ^ Setter + -> ((a -> w b) -> s -> w t) -- ^ Updater + -> (a -> r' s) -- ^ Backward getter + -> (t -> a -> w' b) -- ^ Backward setter + -> ((s -> w' t) -> a -> w' b) -- ^ Backward updater + -> Reference w r w' r' s t a b +bireference get set upd get' set' upd' + = Reference (\f s -> get s >>= f) set upd + (\f s -> get' s >>= f) set' upd' + -- | Creates a reference. -reference :: ( Functor w, Applicative w, Monad w - , Functor r, Applicative r, Monad r ) +reference :: ( RefMonads w r ) => (s -> r a) -- ^ Getter -> (b -> s -> w t) -- ^ Setter -> ((a -> w b) -> s -> w t) -- ^ Updater - -> Reference w r s t a b -reference gets = Reference (\f s -> gets s >>= f) + -> Reference w r MU MU s t a b +reference gets sets updates = Reference (\f s -> gets s >>= f) sets updates + (\_ _ -> MU) (\_ _ -> MU) (\_ _ -> MU) +-- | Creates a reference where all operations are added in their original form. +-- +-- The use of this method is not suggested, because it is closely related to the +-- representation of the references. +rawReference :: (RefMonads w r, RefMonads w' r') + => (forall x . (a -> r x) -> s -> r x) -- ^ Getter + -> (b -> s -> w t) -- ^ Setter + -> ((a -> w b) -> s -> w t) -- ^ Updater + -> (forall x . (s -> r' x) -> a -> r' x) -- ^ Backward getter + -> (t -> a -> w' b) -- ^ Backward setter + -> ((s -> w' t) -> a -> w' b) -- ^ Backward updater + -> Reference w r w' r' s t a b +rawReference = Reference + -- | Creates a reference with explicit close operations that are executed -- after the data is accessed. referenceWithClose @@ -107,12 +136,28 @@ -> (s -> w ()) -- ^ Close after setting -> ((a -> w b) -> s -> w t) -- ^ Updater -> (s -> w ()) -- ^ Close after updating - -> Reference w r s t a b + -> Reference w r MU MU s t a b referenceWithClose get getClose set setClose update updateClose = Reference (\f s -> (get s >>= f) <* getClose s) (\b s -> set b s <* setClose s) (\trf s -> update trf s <* updateClose s) + (\_ _ -> MU) (\_ _ -> MU) (\_ _ -> MU) + +-- | Polymorph unit type. Can represent a calculation that cannot calculate anything. +data MU a = MU +instance Functor MU where + fmap _ _ = MU +instance Applicative MU where + pure _ = MU + _ <*> _ = MU +instance Monad MU where + return _ = MU + _ >>= _ = MU +instance MonadPlus MU where + mzero = MU + mplus _ _ = MU + -- | A simple class to enforce that both reader and writer semantics of the reference are 'Monad's -- (as well as 'Applicative's and 'Functor's) class ( Functor w, Applicative w, Monad w @@ -127,22 +172,34 @@ type Simple t s a = t s s a a -- * Pure references - + +-- | A two-way 'Reference' that represents an isomorphism between two datatypes. +-- Can be used to access the same data in two different representations. +type Iso s t a b + = forall w r w' r' . (RefMonads w r, RefMonads w' r') => Reference w r w' r' s t a b + +-- | A partial lens that can be turned to get a total lens. +type Prism s t a b + = forall w r w' r' . (RefMonads w r, RefMonads w' r' + , MonadPlus r, MMorph Maybe r + , MonadPlus w', MMorph Maybe w') + => Reference w r w' r' s t a b + -- | A 'Reference' that can access a part of data that exists in the context. -- Every well-formed 'Reference' is a 'Lens'. type Lens s t a b - = forall w r . RefMonads w r => Reference w r s t a b + = forall w r . RefMonads w r => Reference w r MU MU s t a b -- | Strict lens. A 'Reference' that must access a part of data that surely exists -- in the context. -type Lens' = Reference Identity Identity +type Lens' = Reference Identity Identity MU MU -- | A reference that may not have the accessed element, and that can -- look for the accessed element in multiple locations. type RefPlus s t a b = forall w r . ( RefMonads w r, MonadPlus r ) - => Reference w r s t a b - + => Reference w r MU MU s t a b + -- | Partial lens. A 'Reference' that can access data that may not exist in the context. -- Every lens is a partial lens. -- @@ -152,11 +209,11 @@ type Partial s t a b = forall w r . ( Functor w, Applicative w, Monad w , Functor r, Applicative r, MonadPlus r, MMorph Maybe r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | Strict partial lens. A 'Reference' that must access data that may not exist -- in the context. -type Partial' = Reference Identity Maybe +type Partial' = Reference Identity Maybe MU MU -- | A reference that can access data that is available in a number of instances -- inside the contexts. @@ -165,12 +222,12 @@ -- updater in the exactly the same number of times that is the number of the values -- returned by it's 'getRef' function. type Traversal s t a b - = forall w r . (RefMonads w r, MonadPlus r, MMorph [] r ) - => Reference w r s t a b + = forall w r . (RefMonads w r, MonadPlus r, MMorph Maybe r, MMorph [] r ) + => Reference w r MU MU s t a b -- | Strict traversal. A reference that must access data that is available in a -- number of instances inside the context. -type Traversal' = Reference Identity [] +type Traversal' = Reference Identity [] MU MU -- * References for 'IO' @@ -183,87 +240,120 @@ -- | A reference that can access mutable data. type IOLens s t a b = forall w r . ( RefMonads w r, IOMonads w r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | A reference that must access mutable data that is available in the context. -type IOLens' = Reference IO IO +type IOLens' = Reference IO IO MU MU -- | 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, IOMonads w r, MonadPlus r, MMorph Maybe r ) - => Reference w r s t a b + => Reference w r MU MU 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 IOPartial' = Reference IO (MaybeT IO) MU MU type IOTraversal s t a b - = forall w r . ( RefMonads w r, IOMonads w r, MonadPlus r, MMorph [] r ) - => Reference w r s t a b + = forall w r . ( RefMonads w r, IOMonads w r, MonadPlus r, MMorph Maybe r, MMorph [] r ) + => Reference w r MU MU s t a b -- | A reference that can access mutable data that is available in a number of -- instances inside the contexts. -type IOTraversal' = Reference IO (ListT IO) +type IOTraversal' = Reference IO (ListT IO) MU MU -- * References for 'StateT' -- | A reference that can access a value inside a 'StateT' transformed monad. type StateLens st m s t a b = forall w r . ( RefMonads w r, MMorph (StateT st m) w, MMorph (StateT st m) r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'StateT' transformed monad. -type StateLens' s m = Reference (StateT s m) (StateT s m) +type StateLens' s m = Reference (StateT s m) (StateT s m) MU MU -- | A reference that can access a value inside a 'StateT' transformed monad -- that may not exist. type StatePartial st m s t a b = forall w r . ( RefMonads w r, MMorph (StateT st m) w, MonadPlus r, MMorph Maybe r, MMorph (StateT st m) r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'StateT' transformed monad -- that may not exist. -type StatePartial' s m = Reference (StateT s m) (MaybeT (StateT s m)) +type StatePartial' s m = Reference (StateT s m) (MaybeT (StateT s m)) MU MU -- | A reference that can access a value inside a 'StateT' transformed monad -- that may exist in multiple instances. type StateTraversal st m s t a b - = forall w r . ( RefMonads w r, MMorph (StateT st m) w, MonadPlus r, MMorph [] r, MMorph (StateT st m) r ) - => Reference w r s t a b + = forall w r . ( RefMonads w r, MMorph (StateT st m) w, MonadPlus r, MMorph Maybe r, MMorph [] r, MMorph (StateT st m) r ) + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'StateT' transformed monad -- that may exist in multiple instances. -type StateTraversal' s m = Reference (StateT s m) (ListT (StateT s m)) +type StateTraversal' s m = Reference (StateT s m) (ListT (StateT s m)) MU MU -- * References for 'WriterT' -- | A reference that can access a value inside a 'WriterT' transformed monad. type WriterLens st m s t a b = forall w r . ( RefMonads w r, MMorph (WriterT st m) w, MMorph (WriterT st m) r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'WriterT' transformed monad. -type WriterLens' s m = Reference (WriterT s m) (WriterT s m) +type WriterLens' s m = Reference (WriterT s m) (WriterT s m) MU MU -- | A reference that can access a value inside a 'WriterT' transformed monad -- that may not exist. type WriterPartial st m s t a b = forall w r . ( RefMonads w r, MMorph (WriterT st m) w, MonadPlus r, MMorph Maybe r, MMorph (WriterT st m) r ) - => Reference w r s t a b + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'WriteT' transformed monad -- that may not exist. -type WriterPartial' s m = Reference (WriterT s m) (MaybeT (WriterT s m)) +type WriterPartial' s m = Reference (WriterT s m) (MaybeT (WriterT s m)) MU MU -- | A reference that can access a value inside a 'WriteT' transformed monad -- that may exist in multiple instances. type WriterTraversal st m s t a b - = forall w r . ( RefMonads w r, MMorph (WriterT st m) w, MonadPlus r, MMorph [] r, MMorph (WriterT st m) r ) - => Reference w r s t a b + = forall w r . ( RefMonads w r, MMorph (WriterT st m) w, MonadPlus r, MMorph Maybe r, MMorph [] r, MMorph (WriterT st m) r ) + => Reference w r MU MU s t a b -- | A reference that must access a value inside a 'WriteT' transformed monad -- that may exist in multiple instances. -type WriterTraversal' s m = Reference (WriterT s m) (ListT (WriterT s m)) +type WriterTraversal' s m = Reference (WriterT s m) (ListT (WriterT s m)) MU MU + + +-- * References for 'ST' + +-- | A reference that can access a value inside an 'ST' transformed monad. +type STLens st s t a b + = forall w r . ( RefMonads w r, MMorph (ST st) w, MMorph (ST st) r ) + => Reference w r MU MU s t a b + +-- | A reference that must access a value inside an 'ST' transformed monad. +type STLens' s = Reference (ST s) (ST s) MU MU + +-- | A reference that can access a value inside an 'ST' transformed monad +-- that may not exist. +type STPartial st s t a b + = forall w r . ( RefMonads w r, MMorph (ST st) w, MonadPlus r, MMorph Maybe r, MMorph (ST st) r ) + => Reference w r MU MU s t a b + +-- | A reference that must access a value inside an 'ST' transformed monad +-- that may not exist. +type STPartial' s = Reference (ST s) (MaybeT (ST s)) MU MU + +-- | A reference that can access a value inside an 'ST' transformed monad +-- that may exist in multiple instances. +type STTraversal st s t a b + = forall w r . ( RefMonads w r, MMorph (ST st) w, MonadPlus r, MMorph Maybe r, MMorph [] r, MMorph (ST st) r ) + => Reference w r MU MU s t a b + +-- | A reference that must access a value inside an 'ST' transformed monad +-- that may exist in multiple instances. +type STTraversal' s = Reference (ST s) (ListT (ST s)) MU MU + + -- | States that 'm1' can be represented with 'm2'. -- That is because 'm2' contains more infromation than 'm1'. -- @@ -293,4 +383,16 @@ instance MMorph Identity [] where morph = return . runIdentity + +instance MMorph Maybe Maybe where + morph = id + +instance MMorph Maybe [] where + morph = maybeToList + +instance MMorph [] [] where + morph = id + +instance MMorph m MU where + morph _ = MU
Control/Reference/TH/MonadInstances.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies, RankNTypes #-}+{-# LANGUAGE TypeFamilies, RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} -- | A basic set of instances derived using "Control.Reference.TH.Monad".@@ -24,6 +24,10 @@ import Control.Monad.Identity import Control.Monad.Trans.Maybe as Trans import Control.Monad.Trans.List as Trans+import Control.Monad.Trans (lift)+import Control.Monad.Trans.State (StateT(..))+import Control.Monad.Trans.Writer (WriterT(..))+import Data.Monoid (Monoid) import Data.Maybe import Language.Haskell.TH as TH @@ -35,3 +39,18 @@ $(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 |])++instance Monad m => MMorph [] (ListT (StateT s m)) where+ morph = Trans.ListT . return+ +instance Monad m => MMorph Maybe (ListT (StateT s m)) where+ morph = (morph :: [a] -> ListT (StateT s m) a) . morph++instance (Monad m, Monoid s) => MMorph [] (Trans.ListT (WriterT s m)) where+ morph = Trans.ListT . return+ +instance (Monad m, Monoid s) => MMorph Maybe (ListT (WriterT s m)) where+ morph = (morph :: [a] -> ListT (WriterT s m) a) . morph++instance Monad m => MMorph (StateT s m) (ListT (StateT s m)) where+ morph = lift
Control/Reference/TH/Records.hs view
@@ -53,12 +53,10 @@ import Control.Monad.Trans.State import Control.Applicative -import Control.Reference.Representation -import Control.Reference.Predefined -import Control.Reference.Operators +import Control.Reference.InternalInterface import Control.Reference.Examples.TH -import Control.Reference.TH.MonadInstances import Control.Reference.TupleInstances +import Control.Reference.TH.MonadInstances -- | Shows the generated declarations instead of using them. debugTH :: Q [Dec] -> Q [Dec] @@ -164,11 +162,13 @@ 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) + typVarsBounded = typeVariableNames & 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 @@ -198,13 +198,8 @@ 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) + , (ConE name : map VarE bindVars) ^. turn funApplication , 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
references.cabal view
@@ -1,5 +1,5 @@ name: references -version: 0.2.1.1 +version: 0.2.1.2 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. @@ -8,6 +8,7 @@ There are two things that references can do but the previously mentioned access methods don't. . * References can cooperate with monads, for example IO. + . * References can be added using the @&+&@ operator, to create new lenses more easily. . Basic idea taken from the currently not maintained package <https://hackage.haskell.org/package/yall>. @@ -67,9 +68,13 @@ , Control.Reference.Representation , Control.Reference.Operators , Control.Reference.Predefined + , Control.Reference.Predefined.Containers + , Control.Reference.Predefined.Containers.Tree , Control.Reference.TupleInstances , Control.Reference.InternalInterface build-depends: base >=4.6 && <5 + , text ==1.1.* + , array ==0.5.* , mtl ==2.2.* , transformers ==0.4.* , containers ==0.5.*