references 0.2.1.2 → 0.3.0.0
raw patch · 12 files changed
+402/−703 lines, 12 filesdep +directorydep +filepathdep +instance-controldep −lifted-basedep −monad-controldep −transformers-base
Dependencies added: directory, filepath, instance-control
Dependencies removed: lifted-base, monad-control, transformers-base
Files
- Control/Reference.hs +17/−21
- Control/Reference/Examples/TH.hs +1/−1
- Control/Reference/InternalInterface.hs +2/−6
- Control/Reference/Operators.hs +38/−169
- Control/Reference/Predefined.hs +65/−10
- Control/Reference/Predefined/Containers.hs +152/−151
- Control/Reference/Predefined/Containers/Tree.hs +18/−18
- Control/Reference/Representation.hs +64/−139
- Control/Reference/TH/Monad.hs +0/−95
- Control/Reference/TH/MonadInstances.hs +0/−56
- Control/Reference/TH/Records.hs +11/−14
- references.cabal +34/−23
Control/Reference.hs view
@@ -1,21 +1,17 @@--- | A frontend module for the Control.Reference package--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-, module Control.Reference.TupleInstances-) where--import Control.Reference.InternalInterface-import Control.Reference.Predefined.Containers.Tree---- generator modules-import Control.Reference.TH.Monad-import Control.Reference.TH.Records---- 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.Predefined.Containers.Tree +, module Control.Reference.TH.Records +, module Control.Reference.TupleInstances +) where + +import Control.Reference.InternalInterface +import Control.Reference.Predefined.Containers.Tree() + +-- generator modules +import Control.Reference.TH.Records + +-- generated classes and instances +import Control.Reference.TupleInstances
Control/Reference/Examples/TH.hs view
@@ -33,7 +33,7 @@ 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 + = 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
Control/Reference/InternalInterface.hs view
@@ -8,17 +8,13 @@ -- For creating a new interface with different generated elements, use this internal interface. -- module Control.Reference.InternalInterface - ( Simple, Reference, bireference, reference, referenceWithClose + ( Reference, bireference, reference, referenceWithClose , Iso + , Simple, Getter, Setter , 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 , module Control.Reference.Predefined.Containers
Control/Reference/Operators.hs view
@@ -2,221 +2,91 @@ {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase, TypeOperators #-} --- | 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' (@!@). +-- | Common operators for using, transforming and combining. -- --- * 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. +-- There are four kinds of operator for every type of reference. +-- The operators are either getters ('^.' and '^?'), setters ('.=' and '!='), +-- monadic updaters ('.~' and '!~'), pure updaters ('.-' and '!-') or action performers (@!|@). -- --- * Generic operators (@#@) do not bind the types of the monads, so they must disambiguated manually. +-- The former operators (with the dot) are pure operators, the later are monadic operators. For example, @(1,2) ^. _1@ results in a pure numeric value, while @Right 4 ^? right@ produces @Just 4@ (or a higher level value representing that). -- module Control.Reference.Operators where import Control.Reference.Representation +import Control.Instances.Morph import Control.Applicative import Control.Monad.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.List --- | Flips a reference to the other direction +-- | Flips a reference to the other direction. +-- The monads of the references can change when a reference is turned. 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 +-- | Gets the context from the referenced element by turning the reference. +review :: Reference MU MU MU Identity s s a a -> 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 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) +-- | Pure getter operator +(^.) :: s -> Getter Identity s a -> a +a ^. l = runIdentity (a ^? l) infixl 4 ^. --- | Partial version of '^#' -(^?) :: s -> Partial' s t a b -> Maybe a -a ^? l = a ^# l +-- | Generic getter operator +(^?) :: Monad m => s -> Getter m s a -> m a +a ^? l = refGet l return a infixl 4 ^? --- | Traversal version of '^#' -(^*) :: s -> Traversal' s t a b -> [a] -a ^* l = a ^# l -infixl 4 ^* - --- | IO version of '^#' -(^!) :: s -> IOLens' s t a b -> IO a -a ^! l = a ^# l -infixl 4 ^! - --- | IO partial version of '^#' -(^?!) :: s -> IOPartial' s t a b -> IO (Maybe a) -a ^?! l = runMaybeT (a ^# l) -infixl 4 ^?! - --- | IO traversal version of '^#' -(^*!) :: s -> IOTraversal' s t a b -> IO [a] -a ^*! l = runListT (a ^# l) -infixl 4 ^*! - -- * Setters --- | 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 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) +-- | Pure setter function +(.=) :: Setter Identity 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 +-- | Monadic setter function +(!=) :: Setter m s t a b -> b -> s -> m t +l != v = refSet 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 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) +-- | Monadic updater with a pure result +(.~) :: Setter Identity 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 +-- | Monadic updater +(!~) :: Setter m s t a b -> (a -> m b) -> s -> m t +l !~ trf = refUpdate 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 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 +-- | Pure updater with pure function +(.-) :: Setter Identity 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 +-- | Monadic update with pure function +(!-) :: Monad m => Setter m s t a b -> (a -> b) -> s -> m 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 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 +-- | Perform a given action monadically +(!|) :: Monad m => Setter m s s a a -> (a -> m c) -> s -> m s +l !| act = l !~ (\v -> act v >> return v) 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. @@ -240,14 +110,14 @@ -- 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] +-- > a ^? twice == [a,a] -- > (twice *= x) a == x --- > (twice *- f) a == f (f a) +-- > (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. -- -(&+&) :: (RefMonads w r, RefMonads w' r', MonadPlus r, MonadPlus r', MMorph [] r) +(&+&) :: (RefMonads w r, RefMonads w' r', MonadPlus r, MonadPlus r', Morph [] 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) @@ -261,7 +131,6 @@ 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')
Control/Reference/Predefined.hs view
@@ -15,22 +15,26 @@ import Control.Reference.Representation import Control.Reference.Operators +import Control.Instances.Morph 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.MVar hiding (modifyMVarMasked_) import Control.Concurrent.Chan import Data.IORef import Data.Either.Combinators import Data.STRef +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error +import qualified Control.Exception as Ex -- * Trivial references @@ -158,7 +162,7 @@ -- | 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:))) @@ -223,6 +227,42 @@ >>= morph . putStrLn >> return Console)) +-- | Reference to the contents of the file. Not thread-safe. +-- +-- An empty file's content is @Just ""@ while a non-existent file's is @Nothing@ +-- +-- Creates a temporary file to store the result. +fileContent :: Simple IOLens FilePath (Maybe String) +fileContent + = reference (\fp -> morph (getFileCont fp)) + (\cont fp -> morph (setFileCont fp cont) >> return fp) + (\trf fp -> morph (getFile fp) >>= \hcnt -> trf (fmap snd hcnt) + >>= morph . updateFileCont fp (fmap fst hcnt) >> return fp) + where getFileCont :: FilePath -> IO (Maybe String) + getFileCont fp = (Just <$> readFile fp) + `Ex.catch` \e -> if isDoesNotExistError e then return Nothing + else Ex.throw e + getFile :: FilePath -> IO (Maybe (Handle, String)) + getFile fp = do h <- (Just <$> openFile fp ReadMode) + `Ex.catch` \e -> if isDoesNotExistError e then return Nothing + else Ex.throw e + case h of + Just handle -> do cont <- hGetContents handle + `Ex.catch` \e -> hClose handle >> Ex.throw (e :: Ex.SomeException) + return $ Just (handle, cont) + Nothing -> return Nothing + + setFileCont :: FilePath -> Maybe String -> IO () + setFileCont fp Nothing = removeFile fp + setFileCont fp (Just cont) = writeFile fp cont + + updateFileCont :: FilePath -> Maybe Handle -> Maybe String -> IO () + updateFileCont fp h Nothing = (just !| hClose) h >> removeFile fp + updateFileCont fp h (Just cont) + = Ex.bracket (openTempFile (takeDirectory fp) (takeFileName fp)) + (\(tfp,th) -> hClose th >> (just !| hClose) h >> removeFile tfp) + (\(_,th) -> hPutStr th cont >> (just !| hClose) h >> hSeek th AbsoluteSeek 0 + >> hGetContents th >>= writeFile fp) -- | Access a value inside an MVar. -- Setting is not atomic. If there is two supplier that may set the accessed @@ -231,15 +271,30 @@ -- Reads and updates are done in sequence, always using consistent data. 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) + (\f mv -> pullBack $ withMVarMasked mv (sink . f)) + (\newVal mv -> morph $ 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) + unusableOp unusableOp unusableOp +-- | Generalized version of 'Control.Concurrent.MVar.modifyMVarMasked_'. +modifyMVarMasked_ :: (Monad m, Morph IO m, MorphControl IO m) => MVar a -> (a -> m a) -> m () +modifyMVarMasked_ m io = + mask_ $ do + a <- morph (takeMVar m) + a' <- io a `onException` morph (putMVar m a) + morph (putMVar m a') +-- | Generalized version of 'Control.Exception.mask_'. +mask_ :: (MorphControl IO m) => m a -> m a +mask_ = pullBack . Ex.mask_ . sink + +-- | Generalized version of 'Control.Exception.onException'. +onException :: (MorphControl IO m) => m a -> m b -> m a +onException a b = pullBack $ Ex.onException (sink a) (sink b) + chan :: Simple IOLens (Chan a) a chan = reference (morph . readChan) (\a ch -> morph (writeChan ch a) >> return ch)
Control/Reference/Predefined/Containers.hs view
@@ -1,152 +1,153 @@-{-# 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+{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} +module Control.Reference.Predefined.Containers where + +import Control.Instances.Morph +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
@@ -1,19 +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+{-# 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
@@ -9,17 +9,15 @@ -- This module should not be imported directly. module Control.Reference.Representation where -import Data.Maybe (maybeToList) +import Data.Proxy +import Control.Instances.Morph 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 Control.Monad.ST (ST) -import Control.Monad.Trans.Control (MonadBaseControl) -- | A reference is an accessor to a part or different view of some data. -- The referenc has a separate getter, setter and updater. In some cases, @@ -72,7 +70,7 @@ -- -- Usually 's' and 'b' determines 't', 't' and 'a' determines 's'. -- --- The reader monad usually have more information (@MMorph 'w' 'r'@). +-- The reader monad usually have more information (@Morph 'w' 'r'@). -- data Reference w r w' r' s t a b @@ -109,7 +107,7 @@ -> ((a -> w b) -> s -> w t) -- ^ Updater -> Reference w r MU MU s t a b reference gets sets updates = Reference (\f s -> gets s >>= f) sets updates - (\_ _ -> MU) (\_ _ -> MU) (\_ _ -> MU) + unusableOp unusableOp unusableOp -- | Creates a reference where all operations are added in their original form. -- @@ -141,23 +139,8 @@ = 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 - + unusableOp unusableOp unusableOp + -- | 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 @@ -167,10 +150,27 @@ , Functor r, Applicative r, Monad r ) => RefMonads w r where +type MU = Proxy + +instance Alternative MU where + empty = Proxy + _ <|> _ = Proxy + +instance MonadPlus MU where + mzero = Proxy + mplus _ _ = Proxy + +unusableOp :: a -> b -> MU c +unusableOp _ _ = Proxy + -- | 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 +type Getter r s a = Reference MU r MU MU s s a a + +type Setter w s t a b = Reference w MU MU MU s t a b + -- * Pure references -- | A two-way 'Reference' that represents an isomorphism between two datatypes. @@ -181,8 +181,8 @@ -- | 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') + , MonadPlus r, Morph Maybe r + , MonadPlus w', Morph 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. @@ -190,10 +190,6 @@ type Lens 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 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 @@ -208,13 +204,9 @@ -- 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 ) + , Functor r, Applicative r, MonadPlus r, Morph Maybe r ) => 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 MU MU - + -- | A reference that can access data that is available in a number of instances -- inside the contexts. -- @@ -222,177 +214,110 @@ -- 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 Maybe r, MMorph [] r ) + = forall w r . (RefMonads w r, MonadPlus r, Morph Maybe r, Morph [] 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 [] MU MU - -- * References for 'IO' -class ( MMorph IO w, MMorph IO r - , MonadBaseControl IO w, MonadBaseControl IO r ) => IOMonads w r where - -instance ( MMorph IO w, MMorph IO r - , MonadBaseControl IO w, MonadBaseControl IO r ) => IOMonads w r where +class ( Morph IO w, Morph IO r + , MorphControl IO w, MorphControl IO r ) => IOMonads w r where +instance ( Morph IO w, Morph IO r + , MorphControl IO w, MorphControl IO r ) => IOMonads w r where -- | A reference that can access mutable data. type IOLens s t a b = forall w r . ( RefMonads w r, IOMonads w r ) => 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 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 ) + = forall w r . (RefMonads w r, IOMonads w r, MonadPlus r, Morph Maybe r ) => 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) MU MU - type IOTraversal s t a b - = forall w r . ( RefMonads w r, IOMonads w r, MonadPlus r, MMorph Maybe r, MMorph [] r ) + = forall w r . ( RefMonads w r, IOMonads w r, MonadPlus r, Morph Maybe r, Morph [] 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) 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 ) + = forall w r . ( RefMonads w r, Morph (StateT st m) w, Morph (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. -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 ) + = forall w r . ( RefMonads w r, Morph (StateT st m) w, MonadPlus r, Morph Maybe r, Morph (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 not exist. -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 Maybe r, MMorph [] r, MMorph (StateT st m) r ) + = forall w r . ( RefMonads w r, Morph (StateT st m) w, MonadPlus r, Morph Maybe r, Morph [] r, Morph (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)) 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 ) + = forall w r . ( RefMonads w r, Morph (WriterT st m) w, Morph (WriterT st m) r ) => 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) 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 ) + = forall w r . ( RefMonads w r, Morph (WriterT st m) w, MonadPlus r, Morph Maybe r, Morph (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 not exist. -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 Maybe r, MMorph [] r, MMorph (WriterT st m) r ) + = forall w r . ( RefMonads w r, Morph (WriterT st m) w, MonadPlus r, Morph Maybe r, Morph [] r, Morph (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)) 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 ) + = forall w r . ( RefMonads w r, Morph (ST st) w, Morph (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 ) + = forall w r . ( RefMonads w r, Morph (ST st) w, MonadPlus r, Morph Maybe r, Morph (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 ) + = forall w r . ( RefMonads w r, Morph (ST st) w, MonadPlus r, Morph Maybe r, Morph [] r, Morph (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'. --- --- 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 - -instance MMorph IO (MaybeT IO) where - morph = MaybeT . liftM Just - -instance MMorph IO (ListT IO) where - morph = ListT . liftM (:[]) - -instance MMorph IO IO where - morph = id - -instance MMorph Identity Maybe where - morph = return . runIdentity - -instance MMorph Identity [] where - morph = return . runIdentity +class MorphControl (m1 :: * -> *) (m2 :: * -> *) where + type MSt m1 m2 :: * -> * + sink :: m2 a -> m1 (MSt m1 m2 a) + pullBack :: m1 (MSt m1 m2 a) -> m2 a -instance MMorph Maybe Maybe where - morph = id +instance MorphControl IO (MaybeT IO) where + type MSt IO (MaybeT IO) = Maybe + sink (MaybeT m) = m + pullBack = MaybeT -instance MMorph Maybe [] where - morph = maybeToList +-- FIXME: conflicts with MorphControl m MU +-- instance (Monad m, Morph m m) => MorphControl m m where + -- type MSt m m = Identity + -- sink m = m >>= return . Identity + -- pullBack m = m >>= return . runIdentity -instance MMorph [] [] where - morph = id +instance (Monad IO, Morph IO IO) => MorphControl IO IO where + type MSt IO IO = Identity + sink m = m >>= return . Identity + pullBack m = m >>= return . runIdentity -instance MMorph m MU where - morph _ = MU +instance (Monad m, Morph m MU) => MorphControl m MU where + type MSt m MU = Proxy + sink _ = return Proxy + pullBack _ = Proxy
− Control/Reference/TH/Monad.hs
@@ -1,95 +0,0 @@-{-# 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
@@ -1,56 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies, RankNTypes, ScopedTypeVariables #-}-{-# 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 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--$(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 |])--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
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase, TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-| This module can be used to generate references for record fields. @@ -48,15 +48,12 @@ import Data.Maybe import Control.Monad import Control.Monad.Writer -import Control.Monad.Trans -import Control.Monad.Trans.List import Control.Monad.Trans.State -import Control.Applicative +import Control.Instances.Morph import Control.Reference.InternalInterface import Control.Reference.Examples.TH import Control.Reference.TupleInstances -import Control.Reference.TH.MonadInstances -- | Shows the generated declarations instead of using them. debugTH :: Q [Dec] -> Q [Dec] @@ -136,21 +133,20 @@ `AppE` TupE [ VarE (vars !! bindInd) , LamE [VarP setVar] (funApplication & element (bindInd+1) - ?= VarE setVar $ rebuild) + .= VarE setVar $ rebuild) ] return $ Match bind (NormalB bindRight) [] matchWithoutField :: Con -> Q Match matchWithoutField con = do (bind, rebuild, _) <- bindAndRebuild con - return $ Match bind (NormalB (ConE 'Left `AppE` rebuild)) [] - + return $ Match bind (NormalB (ConE 'Left `AppE` rebuild)) [] referenceType :: Type -> Name -> [TyVarBndr] -> Type -> Q Type referenceType refType name args fldTyp - = do let argTypes = args ^* traverse&typeVarName + = do let argTypes = args ^? traverse&typeVarName (fldTyp',mapping) <- makePoly argTypes fldTyp - let args' = traverse&typeVarName *- (\a -> fromMaybe a (mapping ^? element a)) $ 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' @@ -160,8 +156,8 @@ -- | Creates a new field type with changing the type variables that are bound outside makePoly :: [Name] -> Type -> Q (Type, M.Map Name Name) makePoly typArgs fldTyp - = runStateT (typVarsBounded #~ updateName $ fldTyp) M.empty - where typVarsBounded :: Simple (StateTraversal' (M.Map Name Name) Q) Type Name + = runStateT (typVarsBounded !~ updateName $ fldTyp) M.empty + where typVarsBounded :: Simple (StateTraversal (M.Map Name Name) Q) Type Name typVarsBounded = typeVariableNames & filtered (`elem` typArgs) updateName name = do name' <- lift (newName (nameBase name ++ "'")) modify (M.insert name name') @@ -177,7 +173,7 @@ -- * Helper functions hasField :: Name -> Con -> Bool -hasField n = not . null . (^* recFields & traverse & _1 & filtered (==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) @@ -202,4 +198,5 @@ , bindVars ) - +instance Morph (StateT s m) (StateT s m) where + morph = id
references.cabal view
@@ -1,13 +1,18 @@ name: references -version: 0.2.1.2 +version: 0.3.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>). + +description: References are data accessors that can read, write or update the accessed infromation through their context. 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>). . + References are more general than field selectors in traditional languages. + . + * References are first-class values. If there is a struct in C, for example, with an `int` field `fl`, then fl can only be used as part of an expression. One can not generalize a function to take a field selector and transform the selected data or use it in other ways. + . + * They can have different meanings, while field accessors can only represent data-level containment. They can express uncertain containment (like field selectors of C unions), different viewpoints of the same data, and other concepts. + . 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 cooperate with monads, for example IO. This opens many new applications. . * References can be added using the @&+&@ operator, to create new lenses more easily. . @@ -17,7 +22,7 @@ . > logger = > (forever $ do - > log <- logChan ^! chan&logRecord -- Extract the log record from the received log message + > 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 @@ -28,7 +33,7 @@ > mvar !- (thrId:) $ updaters -- Record the spawned thread > ) `catch` stopUpdaters updaters > where stopUpdaters updaters ThreadKilled = - > mvar&traverse *!| killThread $ updaters -- Kill all spawned threads before stopping + > mvar&traverse !| killThread $ updaters -- Kill all spawned threads before stopping . There are a bunch of predefined references for datatypes included in standard libraries. . @@ -43,11 +48,9 @@ * 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. + * Generating references for newly defined datatypes using the `makeReferences` Template Haskell function. . - - homepage: https://github.com/lazac/references license: BSD3 license-file: LICENSE @@ -58,10 +61,18 @@ build-type: Simple cabal-version: >=1.8 +-- For some reason, cabal won't allow me to write this: +-- +-- source-repository: head +-- type: git +-- location: git://github.com/lazac/references.git +-- source-repository: this +-- type: git +-- location: git://github.com/lazac/references.git +-- tag: 0.2.1.2 + library exposed-modules: Control.Reference - , Control.Reference.TH.MonadInstances - , Control.Reference.TH.Monad , Control.Reference.TH.Records , Control.Reference.TH.Tuple , Control.Reference.Examples.TH @@ -72,14 +83,14 @@ , 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.* - , either ==4.3.* - , template-haskell >=2.8 && <3 - , transformers-base >= 0.4 && <0.5 - , monad-control >= 0.3 && <0.4 - , lifted-base >= 0.2 && <0.3+ build-depends: base >= 4.6 && < 5 + , text == 1.1.* + , array == 0.5.* + , mtl == 2.2.* + , transformers == 0.4.* + , containers == 0.5.* + , either == 4.3.* + , template-haskell >= 2.8 && < 3 + , instance-control == 0.1.* + , directory == 1.2.* + , filepath == 1.3.*