references 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+1060/−830 lines, 15 filesdep +lifted-basedep +monad-controldep +transformers-basedep ~basedep ~template-haskellsetup-changed
Dependencies added: lifted-base, monad-control, transformers-base
Dependency ranges changed: base, template-haskell
Files
- Control/Reference.hs +19/−20
- Control/Reference/Examples/Examples.hs +0/−93
- Control/Reference/Examples/TH.hs +20/−36
- Control/Reference/InternalInterface.hs +27/−0
- Control/Reference/Operators.hs +228/−62
- Control/Reference/Predefined.hs +151/−188
- Control/Reference/Representation.hs +242/−61
- Control/Reference/TH/Generate.hs +81/−67
- Control/Reference/TH/Monad.hs +95/−136
- Control/Reference/TH/MonadInstances.hs +37/−35
- Control/Reference/TH/Tuple.hs +69/−76
- Control/Reference/TupleInstances.hs +12/−12
- LICENSE +27/−30
- Setup.hs +2/−2
- references.cabal +50/−12
Control/Reference.hs view
@@ -1,20 +1,19 @@--- | 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 +-- | A frontend module for the Control.Reference package++module Control.Reference+( module Control.Reference.InternalInterface+, module Control.Reference.TH.Monad+, module Control.Reference.TH.Generate+, module Control.Reference.TH.MonadInstances+, module Control.Reference.TupleInstances+) where++import Control.Reference.InternalInterface++-- generator modules+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
@@ -1,93 +0,0 @@-{-# 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
@@ -1,55 +1,41 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE LiberalTypeSynonyms, FlexibleContexts #-} --- | 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. +-- | An example module that adds references for Template Haskell. +-- These references are used to create the TH functions that generate references. module Control.Reference.Examples.TH where -import Language.Haskell.TH - -import Control.Reference.Representation -import Control.Reference.Predefined +import Control.Reference.InternalInterface import Control.Applicative +import Language.Haskell.TH -- | Reference all type variables inside a type -typeVariables :: (Applicative w, Monad w) => Traversal' w Type Type Name Name -typeVariables = fromTraversal freeTypeVariables' freeTypeVariables' +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 -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 :: Simple Lens TyVarBndr 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 :: Simple Lens Name 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 +-- | Reference the record fields in a constructor. +recFields :: Simple Partial Con [(Name, Strict, Type)] +recFields = partial (\case (RecC name flds) -> Right (flds, \flds' -> RecC name flds') + c -> Left c) -conFields :: Monad w => Simple' w Lens' Con [(Strict, Type)] +-- | Reference all fields (data members) in a constructor. +conFields :: Simple Lens Con [(Strict, Type)] conFields = lens getFlds setFlds where getFlds (NormalC _ flds) = flds getFlds (RecC _ flds) = map (\(_,a,b) -> (a,b)) flds @@ -61,9 +47,7 @@ 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 - +-- | Reference the name of the constructor conName :: Simple Lens Con Name conName = lens getName setName where getName (NormalC n _) = n @@ -76,11 +60,11 @@ 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] +-- | 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) where unfoldExpr ls (AppE l r) = unfoldExpr (r : ls) l unfoldExpr ls e = e : ls - -funApplication' :: Simple Lens Exp [Exp] -funApplication' = funApplication +
+ Control/Reference/InternalInterface.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_HADDOCK not-home #-} + +-- | An interface with references that can be used internally while generating instances +-- for 'MMorph' and tuple lens classes. +-- +-- Only the public parts of "Control.Reference.Representation" are exported. +-- +-- For creating a new interface with different generated elements, use this internal interface. +-- +module Control.Reference.InternalInterface + ( Simple, Reference, reference, referenceWithClose + , Lens, Partial, Traversal + , Lens', Partial', Traversal' + , IOLens, IOPartial, IOTraversal + , IOLens', IOPartial', IOTraversal' + , StateLens, StatePartial, StateTraversal + , StateLens', StatePartial', StateTraversal' + , WriterLens, WriterPartial, WriterTraversal + , WriterLens', WriterPartial', WriterTraversal' + , MMorph(..) + , module Control.Reference.Operators + , module Control.Reference.Predefined + ) where + +import Control.Reference.Representation +import Control.Reference.Operators +import Control.Reference.Predefined
Control/Reference/Operators.hs view
@@ -1,77 +1,243 @@-{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase, TypeOperators #-} --- | Common operators for references -module Control.Reference.Operators where +-- | Common operators for references. References bind the types of the read and write monads of +-- a reference. +-- +-- The naming of the operators follows the given convetions: +-- +-- * There are four kinds of operator for every type of reference. +-- The operators are either getters (@^_@), setters (@_=@), monadic updaters (@_~@), +-- pure updaters (@_-@) or action performers (@_|@). +-- The @_@ will be replaced with the signs of the monads accessable. +-- +-- * There are pure operators for 'Lens' (@.@), partial operators for 'Partial' lenses (@?@), +-- operators for 'Traversal' (@*@), and operators that work inside 'IO' for 'IOLens' (@!@). +-- +-- * Different reference types can be combined, the outermost monad is the first character. +-- Example: Partial IO lens (@?!@). But partial lens and traversal combined is simply a traversal. +-- +-- * Generic operators (@#@) do not bind the types of the monads, so they must disambiguated manually. +-- +module Control.Reference.Operators where import Control.Reference.Representation - import Control.Monad.Identity - -infixl 4 .~ -infixl 4 .= -infixl 4 %~ -infixl 4 %~= -infixl 4 %= +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.List + +-- * 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 +a ^# l = refGet l return a +infixl 4 ^# + +-- | Pure version of '^#' +(^.) :: s -> Lens' s t a b -> a +a ^. l = runIdentity (a ^# l) infixl 4 ^. + +-- | Partial version of '^#' +(^?) :: s -> Partial' s t a b -> Maybe a +a ^? l = a ^# l 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) +-- | Traversal version of '^#' +(^*) :: s -> Traversal' s t a b -> [a] +a ^* l = a ^# l +infixl 4 ^* --- | 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 +-- | IO version of '^#' +(^!) :: s -> IOLens' s t a b -> IO a +a ^! l = a ^# l +infixl 4 ^! --- | 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) +-- | IO partial version of '^#' +(^?!) :: s -> IOPartial' s t a b -> IO (Maybe a) +a ^?! l = runMaybeT (a ^# l) +infixl 4 ^?! --- | 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) +-- | IO traversal version of '^#' +(^*!) :: s -> IOTraversal' s t a b -> IO [a] +a ^*! l = runListT (a ^# l) +infixl 4 ^*! --- | 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 +-- * Setters --- | 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 - +-- | 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 +l #= v = refSet l v +infixl 4 #= + +-- | Pure version of '#=' +(.=) :: Lens' s t a b -> b -> s -> t +l .= v = runIdentity . (l #= v) +infixl 4 .= + +-- | Partial version of '#=' +(?=) :: Partial' s t a b -> b -> s -> t +l ?= v = runIdentity . (l #= v) +infixl 4 ?= + +-- | Traversal version of '#=' +(*=) :: Traversal' s t a b -> b -> s -> t +l *= v = runIdentity . (l #= v) +infixl 4 *= + +-- | IO version of '#=' +(!=) :: IOLens' s t a b -> b -> s -> IO t +l != v = l #= v +infixl 4 != + +-- | Partial IO version of '#=' +(?!=) :: IOPartial' s t a b -> b -> s -> IO t +l ?!= v = l #= v +infixl 4 ?!= + +-- | Traversal IO version of '#=' +(*!=) :: IOTraversal' s t a b -> b -> s -> IO t +l *!= v = l #= v +infixl 4 *!= + +-- * Updaters + +-- | 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 +l #~ trf = refUpdate l trf +infixl 4 #~ + +-- | Pure version of '#~' +(.~) :: Lens' s t a b -> (a -> Identity b) -> s -> t +l .~ trf = runIdentity . (l #~ trf) +infixl 4 .~ + +-- | Partial version of '#~' +(?~) :: Partial' s t a b -> (a -> Identity b) -> s -> t +l ?~ trf = runIdentity . (l #~ trf) +infixl 4 ?~ + +-- | Traversal version of '#~' +(*~) :: Traversal' s t a b -> (a -> Identity b) -> s -> t +l *~ trf = runIdentity . (l #~ trf) +infixl 4 *~ + +-- | IO version of '#~' +(!~) :: IOLens' s t a b -> (a -> IO b) -> s -> IO t +l !~ trf = l #~ trf +infixl 4 !~ + +-- | Partial IO version of '#~' +(?!~) :: IOPartial' s t a b -> (a -> IO b) -> s -> IO t +l ?!~ trf = l #~ trf +infixl 4 ?!~ + +-- | Traversal IO version of '#~' +(*!~) :: IOTraversal' s t a b -> (a -> IO b) -> s -> IO t +l *!~ trf = l #~ trf +infixl 4 *!~ + +-- * Updaters with pure function inside + +-- | 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 +l #- trf = l #~ return . trf +infixl 4 #- + +-- | Pure version of '#-' +(.-) :: Lens' s t a b -> (a -> b) -> s -> t +l .- trf = l .~ return . trf +infixl 4 .- + +-- | Partial version of '#-' +(?-) :: Partial' s t a b -> (a -> b) -> s -> t +l ?- trf = l ?~ return . trf +infixl 4 ?- + +-- | Traversal version of '#-' +(*-) :: Traversal' s t a b -> (a -> b) -> s -> t +l *- trf = l *~ return . trf +infixl 4 *- + +-- | IO version of '#-' +(!-) :: IOLens' s t a b -> (a -> b) -> s -> IO t +l !- trf = l !~ return . trf +infixl 4 !- + +-- | Partial IO version of '#-' +(?!-) :: IOPartial' s t a b -> (a -> b) -> s -> IO t +l ?!- trf = l ?!~ return . trf +infixl 4 ?!- + +-- | Traversal IO version of '#-' +(*!-) :: IOTraversal' s t a b -> (a -> b) -> s -> IO t +l *!- trf = l *!~ return . trf +infixl 4 *!- + +-- * Updaters with only side-effects + +-- | 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 +l #| act = l #~ (\v -> act v >> return v) +infixl 4 #| + +-- | IO version of '#|' +(!|) :: IOLens' s s a a -> (a -> IO c) -> s -> IO s +l !| act = l #| act +infixl 4 !| + +-- | Partial IO version of '#|' +(?!|) :: IOPartial' s s a a -> (a -> IO c) -> s -> IO s +l ?!| act = l #| act +infixl 4 ?!| + +-- | Traversal IO version of '#|' +(*!|) :: IOTraversal' s s a a -> (a -> IO c) -> s -> IO s +l *!| act = l #| act +infixl 4 *!| + +-- * Binary operators on references + +-- | Composes two references. They must be of the same kind. +-- +-- If reference @r@ accesses @b@ inside the context @a@, and reference @p@ accesses @c@ inside the context @b@, +-- 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 +(&) l1 l2 = Reference (refGet l1 . refGet l2) + (refUpdate l1 . refSet l2) + (refUpdate l1 . refUpdate l2) 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 [] - +-- | Adds two references. +-- +-- Using this operator may result in accessing the same parts of data multiple times. +-- For example @ twice = self &+& self @ is a reference that accesses itself twice: +-- +-- > a ^* twice == [a,a] +-- > (twice *= x) a == x +-- > (twice *- f) a == f (f a) +-- +-- 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 +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 ) infixl 5 &+&
Control/Reference/Predefined.hs view
@@ -1,255 +1,218 @@-{-# LANGUAGE LambdaCase, TupleSections #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase, TupleSections, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} {-# LANGUAGE RankNTypes, TypeFamilies, FunctionalDependencies, LiberalTypeSynonyms #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AllowAmbiguousTypes #-} +#endif --- | 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. + +-- | Predefined references for commonly used data structures. +-- +-- 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 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 qualified Data.Traversable as Trav +import Control.Monad.Trans.Control +import Control.Monad.Identity 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 +import Control.Concurrent.MVar.Lifted +import Control.Concurrent.Chan +import Data.IORef +import Data.Map as Map +import Data.Either.Combinators -- * 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 +-- +-- > self & a = a & self = a +self :: Lens a b a b +self = reference return (const . return) id -- | 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 &+& a = a &+& emptyRef = a +-- +-- > a & emptyRef = emptyRef & a = emptyRef +emptyRef :: Simple RefPlus 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)) +-- | Generates a traversal for any 'Trav.Traversable' 'Functor' +traverse :: (Trav.Traversable t) => Traversal (t a) (t b) a b +traverse = reference (morph . execWriter . Trav.mapM (tell . (:[]))) + (Trav.mapM . const . return) Trav.mapM - -traverse' :: (Trav.Traversable t) => Traversal (t a) (t b) a b -traverse' = traverse - + +-- | 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 ) -- | 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) +lens :: (s -> a) -> (b -> s -> t) -> Lens 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 monomorphic partial lense +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) --- | 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)) +-- | 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) + +-- | Clones a lens from "Control.Lens" +fromLens :: (forall f . Functor f => (a -> f b) -> s -> f t) -> Lens s t a b +fromLens l = reference (\s -> return (getConst $ l Const s)) + (\b -> return . (runIdentity . l (\_ -> Identity b))) + l + +-- | Clones a traversal from "Control.Lens" +fromTraversal :: (forall f . Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b +fromTraversal l = reference (morph . execWriter . l (\a -> tell [a] >> return undefined)) + (\b -> return . (runIdentity . l (\_ -> Identity b))) + l - --- | 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 +filtered :: (a -> Bool) -> Simple RefPlus a a +filtered p = reference (\s -> if p s then return s else mzero) + (\a s -> if p s then return a else return s) + (\f s -> if p s then f s else return s) -- * 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 - +just :: Partial (Maybe a) (Maybe b) a b +just = partial (\case Just x -> Right (x, Just) + Nothing -> Left Nothing) + -- | 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 - +right :: Partial (Either a b) (Either a c) b c +right = partial (\case Right x -> Right (x, Right) + Left a -> Left (Left a)) + -- | 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 +left :: Partial (Either a c) (Either b c) a b +left = partial (\case Left a -> Right (a, Left) + Right r -> Left (Right r)) -- | 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 +anyway :: Lens (Either a a) (Either b b) a b +anyway = reference (either return return) + (\b -> return . mapBoth (const b) (const b)) + (\f -> either (f >=> return . Left) (f >=> return . Right)) -- | References both elements of a tuple -both :: Monad w => Traversal' w (a,a) (b,b) a b -both = Reference (\(x,y) -> [x,y]) +both :: Traversal (a,a) (b,b) a b +both = reference (\(x,y) -> morph [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 + (\f (x,y) -> (,) <$> f x <*> f y) -- | 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 +_head :: Simple Partial [a] a +_head = simplePartial (\case [] -> Nothing; x:xs -> Just (x,(:xs))) -- | 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 +_tail :: Simple Partial [a] [a] +_tail = simplePartial (\case [] -> Nothing; x:xs -> Just (xs,(x:))) -- | 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 + element :: AssocIndex e -> Simple Partial e (AssocElem e) instance Association [a] where type AssocIndex [a] = Int type AssocElem [a] = a - element i = Reference (at i) (\v -> update (const (return v))) - update + element i = reference (morph . at i) (\v -> upd (const (return v))) + upd 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 + at n _ | 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 + 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 (Map.lookup k) (\v -> return . insert k v) - (\trf m -> case Map.lookup k m of Just x -> return (insert k x m) + 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) -- * 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) +-- | A dummy object to interact with the user through the console. +data Console = Console --- | 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. +-- | Interacts with a line of text on the console. Values set are printed, getting +-- is reading from the console. +consoleLine :: Simple IOLens Console String +consoleLine + = reference (const (morph getLine)) + (\str -> const (morph (putStrLn str) >> return Console)) + (\f -> const (morph getLine >>= f + >>= morph . putStrLn + >> return Console)) --- 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 a value inside an MVar. +-- Setting is not atomic. If there is two supplier that may set the accessed +-- 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) + + +chan :: Simple IOLens (Chan a) a +chan = reference (morph . readChan) + (\a ch -> morph (writeChan ch a) >> return ch) + (\trf ch -> morph (readChan ch) >>= trf + >>= morph . writeChan ch >> return ch) + +-- | Access the value of an IORef. +ioref :: Simple IOLens (IORef a) a +ioref = reference (morph . readIORef) + (\v ior -> morph (atomicWriteIORef ior v) >> return ior) + (\trf ior -> morph (readIORef ior) + >>= trf >>= morph . 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)) +state :: forall s m a . Monad m => Simple (StateLens s m) a s +state = reference (morph . const get') (\a s -> morph (put' a) >> return s) + (\trf s -> (morph get' >>= trf >> return s)) + where put' = put :: s -> StateT s m () + get' = get :: StateT s m s
Control/Reference/Representation.hs view
@@ -1,17 +1,30 @@-{-# LANGUAGE KindSignatures #-} +{- LANGUAGE CPP -} +{-# LANGUAGE KindSignatures, TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-} + -- | 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 Control.Applicative +import Control.Monad +import Control.Monad.Base +import Control.Monad.State (StateT) +import Control.Monad.Writer (WriterT) 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. +-- The referenc has a separate getter, setter and updater. In some cases, +-- the semantics are a bit different -- -- == Reference laws -- @@ -20,88 +33,256 @@ -- 1) You get back what you put in: -- -- @ --- 'lensSet' l a s >>= 'lensGet' l ≡ a +-- 'refSet' l a s >>= 'refGet' l return ≡ a -- @ -- -- 2) Putting back what you got doesn't change anything: -- -- @ --- 'lensGet' l a >>= \b -> 'lensSet' l b s ≡ s +-- 'refGet' l return a >>= \\b -> 'refSet' l b s ≡ s -- @ -- -- 3) Setting twice is the same as setting once: -- -- @ --- 'lensSet' l a s >>= 'lensSet' l b ≡ 'lensSet' l b s +-- 'refSet' l a s >>= 'refSet' l b ≡ 'refSet' l b s -- @ -- --- But because they are more powerful than lenses, they should be more responsible. +-- But because update, set and get are different operations, . -- --- 4) Updating something is the same as getting and then setting: +-- 4) Updating something is the same as getting and then setting (if the reader and writer monads are the same, or one can be converted into the other): -- -- @ --- 'lensGet' l a >>= f >>= \b -> 'lensSet' l b s ≡ lensUpdate b s +-- 'refGet' l a >>= f >>= \\b -> 'refSet' l b s ≡ 'refUpdate' l f 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. +-- This has some consequences. For example @lensUpdate l id = return@. +-- +-- == Type arguments of 'Reference' +-- ['w'] Writer monad, controls how the value can be reassembled when the part is changed. +-- 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' +-- ['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'. +-- ['a'] The type of the accessed part. +-- ['b'] The accessed part can be changed to something of this type. +-- +-- Usually 's' and 'b' determines 't', 't' and 'a' determines 's'. +-- +-- The reader monad usually have more information (@MMorph 'w' 'r'@). +-- --- 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. +data Reference 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 + -- a read. + , refSet :: b -> s -> w t + -- ^ Setter for the lens + , refUpdate :: (a -> w b) -> s -> w t + -- ^ Updater for the lens. Handles monadic update functions. } - --- | A monomorph 'Lens', 'Traversal', 'LensPart', etc... + +-- | Creates a reference. +reference :: ( Functor w, Applicative w, Monad w + , Functor r, Applicative r, Monad 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) + +-- | Creates a reference with explicit close operations that are executed +-- after the data is accessed. +referenceWithClose + :: ( Functor w, Applicative w, Monad w + , Functor r, Applicative r, Monad r ) + => (s -> r a) -- ^ Getter + -> (s -> r ()) -- ^ Close after getting + -> (b -> s -> w t) -- ^ Setter + -> (s -> w ()) -- ^ Close after setting + -> ((a -> w b) -> s -> w t) -- ^ Updater + -> (s -> w ()) -- ^ Close after updating + -> Reference w r 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) + +-- | 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 + , Functor r, Applicative r, Monad r + ) => RefMonads w r where +instance ( Functor w, Applicative w, Monad w + , Functor r, Applicative r, Monad r ) + => RefMonads w r where + +-- | A monomorph 'Lens', 'Traversal', 'Partial', 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 +-- * Pure references + +-- | 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 + +-- | Strict lens. A 'Reference' that must access a part of data that surely exists +-- in the context. +type Lens' = Reference Identity Identity + +-- | 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 + +-- | Partial lens. A 'Reference' that can access data that may not exist in the context. +-- Every lens is a partial lens. +-- +-- Any reference that is a partial lens should only perform the action given to its +-- 'updateRef' function if it can get a value (the value returned by 'getRef' is not +-- the lifted form of 'Nothing'). +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 + +-- | Strict partial lens. A 'Reference' that must access data that may not exist +-- in the context. +type Partial' = Reference Identity Maybe + +-- | A reference that can access data that is available in a number of instances +-- inside the contexts. +-- +-- Any reference that is a 'Traversal' should perform the action given to its +-- 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 + +-- | Strict traversal. A reference that must access data that is available in a +-- number of instances inside the context. +type Traversal' = Reference Identity [] + +-- * References for 'IO' + +-- | 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 ) + => Reference w r s t a b + +-- | A reference that must access mutable data that is available in the context. +type IOLens' = Reference IO IO + +-- | 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 ) + => 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 ) + => Reference w r 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) + +-- * 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 + +-- | A reference that must access a value inside a 'StateT' transformed monad. +type StateLens' s m = Reference (StateT s m) (StateT s m) + +-- | 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 + +-- | 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)) + +-- | 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 + +-- | 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)) + +-- * 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 + +-- | A reference that must access a value inside a 'WriterT' transformed monad. +type WriterLens' s m = Reference (WriterT s m) (WriterT s m) + +-- | 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 + +-- | 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)) + +-- | 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 + +-- | 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)) --- | The Lens is a reference that represents an 1 to 1 relationship. -type Lens = Reference Identity Identity -type Lens' w = Reference w Identity +-- | States that 'm1' can be represented with 'm2'. +-- That is because 'm2' contains more infromation than 'm1'. +-- +-- The 'MMorph' relation defines a natural transformation from 'm1' to 'm2' +-- that keeps the following laws: +-- +-- > morph (return x) = return x +-- > morph (m >>= f) = morph m >>= morph . f +-- +-- It is a reflexive and transitive relation. +-- +class MMorph (m1 :: * -> *) (m2 :: * -> *) where + -- | Lifts the first monad into the second. + morph :: m1 a -> m2 a --- | The Traversal is a reference that represents an 1 to any relationship. -type Traversal = Reference Identity [] -type Traversal' w = Reference w [] +instance MMorph IO (MaybeT IO) where + morph = MaybeT . liftM Just --- | 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 +instance MMorph IO (ListT IO) where + morph = ListT . liftM (:[]) - --- | 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 +instance MMorph IO IO where + morph = id + +instance MMorph Identity Maybe where + morph = return . runIdentity + +instance MMorph Identity [] where + morph = return . runIdentity --- | 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
@@ -1,49 +1,57 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE LambdaCase #-} +{-# 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 '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 +{-| +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. -import Language.Haskell.TH +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 Debug.Trace import Control.Reference.Representation import Control.Reference.Predefined @@ -52,20 +60,22 @@ 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 - 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" + 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) @@ -74,7 +84,7 @@ createLensForField :: Name -> [TyVarBndr] -> Name -> Name -> Type -> Q [Dec] createLensForField typName typArgs conName fldName fldTyp - = do lTyp <- referenceType (ConT ''Lens') typName typArgs fldTyp + = do lTyp <- referenceType (ConT ''Lens) typName typArgs fldTyp lensBody <- genLensBody return [ SigD lensName lTyp , ValD (VarP lensName) (NormalB $ lensBody) [] @@ -98,7 +108,7 @@ createPartialLensForField :: Name -> [TyVarBndr] -> Name -> [Con] -> Name -> Type -> Q [Dec] createPartialLensForField typName typArgs conName cons fldName fldTyp - = do lTyp <- referenceType (ConT ''LensPart') typName typArgs fldTyp + = do lTyp <- referenceType (ConT ''Partial) typName typArgs fldTyp lensBody <- genLensBody return [ SigD lensName lTyp , ValD (VarP lensName) (NormalB $ lensBody) [] @@ -110,8 +120,10 @@ = do matchesWithField <- mapM matchWithField consWithField matchesWithoutField <- mapM matchWithoutField consWithoutField name <- newName "x" - return $ VarE 'polyPartial - `AppE` LamE [VarP name] (CaseE (VarE name) ( matchesWithField ++ matchesWithoutField )) + return $ VarE 'partial + `AppE` LamE [VarP name] + (CaseE (VarE name) + ( matchesWithField ++ matchesWithoutField )) (consWithField, consWithoutField) = partition (hasField fldName) cons @@ -125,27 +137,24 @@ = ConE 'Right `AppE` TupE [ VarE (vars !! bindInd) , LamE [VarP setVar] - (VarE 'return `AppE` - (funApplication' & element (bindInd+1) - .~ VarE setVar $ rebuild)) + (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))) [] + return $ Match bind (NormalB (ConE 'Left `AppE` rebuild)) [] referenceType :: Type -> Name -> [TyVarBndr] -> Type -> Q Type referenceType refType name args fldTyp - = do w <- newName "w" - let argTypes = args ^? traverse&typeVarName' + = 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 (w : M.elems mapping ++ argTypes)) [ClassP ''Monad [VarT w]] - (refType `AppT` VarT w - `AppT` addTypeArgs name args + 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') @@ -153,30 +162,30 @@ -- | 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 + = 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 +refName = nameBaseStr .- \case '_':xs -> xs; xs -> '_':xs -- * Helper functions hasField :: Name -> Con -> Bool -hasField n = not . null . (^? recFields' & traverse & _1 & filteredTrav (==n)) +hasField n = not . null . (^* recFields & traverse & _1 & filtered (==n)) fieldIndex :: Name -> Con -> Maybe Int -fieldIndex n con = (con ^? recFields') >>= findIndex (\f -> (f ^. _1') == n) +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')) + . map (VarT . (^. typeVarName)) newtypeToData :: Dec -> Dec newtypeToData (NewtypeD ctx name tvars con derives) @@ -186,7 +195,7 @@ bindAndRebuild :: Con -> Q (Pat, Exp, [Name]) bindAndRebuild con = do let name = con ^. conName - fields = con ^. conFields' + fields = con ^. conFields bindVars <- replicateM (length fields) (newName "fld") return ( ConP name (map VarP bindVars) , -- TODO : use funApplication isomorphisms @@ -194,3 +203,8 @@ , 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/Monad.hs view
@@ -1,136 +1,95 @@-{-# 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 - - +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}+{-# LANGUAGE LambdaCase, DoAndIfThenElse, TypeOperators #-}++-- | A module for making connections between different monads.+module Control.Reference.TH.Monad+ (makeMonadRepr+ , ToQType(..)+ , ToQExp(..)+ ) where++import Control.Reference.Representation+import Control.Monad.State+import Data.List+import Data.Maybe+import Language.Haskell.TH++-- | A type name or a type expression, that can be converted+-- into a type inside 'Q'.+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 ++-- | A variable or function name or an expression, that can be converted+-- into an expression inside 'Q'.+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)] } deriving Show+ +-- | Creates 'MMorph' instances from reflectivity, and transitivity of the relation.+-- Uses data from 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 ''MMorph+ let subsumes = map (\(InstanceD _ (AppT (AppT _ below) above) _) -> (below, above))+ subsumeInstances+ evalStateT (makeMonadRepr' t1 t2 e) (IGS subsumes)++makeMonadRepr' :: Type -> Type -> Exp -> IGState Q [Dec]+makeMonadRepr' t1 t2 e+ = do reflexiveSubs <- sequence [ generateSubsume t1 t1 (\_ -> VarE 'id)+ , generateSubsume t2 t2 (\_ -> VarE 'id) + ]+ + (_ , belowM1) <- collectedSubsumes t1+ (aboveM2, _) <- collectedSubsumes t2+ subs <- sequence [ generateSubsume bm am (\x -> liftMSCasted t2 am x @.@ e @.@ liftMSCasted bm t1 x) + | Below bm <- belowM1, Above am <- aboveM2 ]+ return (catMaybes $ reflexiveSubs ++ subs)++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 'morph `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)+ +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 ''MMorph `AppT` m1 `AppT` m2)+ [ FunD 'morph [Clause [] (NormalB (e x)) []] ]+ else return Nothing++
Control/Reference/TH/MonadInstances.hs view
@@ -1,35 +1,37 @@-{-# 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 |]) +{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# 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.InternalInterface+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
@@ -1,76 +1,69 @@-{-# 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 - +{-# 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"+ 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))+ ++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 $ 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)))+ +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
@@ -1,12 +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) - +{-# 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
@@ -1,30 +1,27 @@-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. +Copyright (c) 2014, lazac+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 the {organization} nor the names of its+ 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 HOLDER 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
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
references.cabal view
@@ -1,13 +1,48 @@--- 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. +version: 0.2.0.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. + References generalize lenses, folds and traversals for haskell (see: <https://hackage.haskell.org/package/lens>). + . + 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>. + . + An example use of the references (a logger application that spawns new threads to update a global log): + . + > logger = + > (forever $ do + > log <- logChan ^! chan&logRecord -- Extract the log record from the received log message + > thrId <- forkIO (do time <- getTime + > ioref&lastLogTime != time $ logDB -- Update the last logging time mutable log database + > let logMsg = senderThread .- show -- Transform the thread id to a string and + > $ loggingTime .= time -- update the time + > $ log -- inside the log message + > ioref&debugInfos !~ addLogEntry log $ logDB -- update the table of log entries + > mvar !- (+1) $ count ) + > mvar !- (thrId:) $ updaters -- Record the spawned thread + > ) `catch` stopUpdaters updaters + > where stopUpdaters updaters ThreadKilled = + > mvar&traverse *!| killThread $ updaters -- Kill all spawned threads before stopping + . + There are a bunch of predefined references for datatypes included in standard libraries. + . + 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@, ...). + * 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. + . + + + homepage: https://github.com/lazac/references license: BSD3 license-file: LICENSE @@ -29,11 +64,14 @@ , Control.Reference.Operators , Control.Reference.Predefined , Control.Reference.TupleInstances - other-modules: Control.Reference.Examples.Examples - build-depends: base ==4.7.* + , Control.Reference.InternalInterface + build-depends: base >=4.6 && <5 , mtl ==2.2.* , transformers ==0.4.* , containers ==0.5.* , either ==4.3.* , lens ==4.2.* - , template-haskell ==2.9.*+ , template-haskell >=2.8 && <3 + , transformers-base >= 0.4 && <0.5 + , monad-control >= 0.3 && <0.4 + , lifted-base >= 0.2 && <0.3