diff --git a/Control/Reference.hs b/Control/Reference.hs --- a/Control/Reference.hs +++ b/Control/Reference.hs @@ -2,7 +2,6 @@ module Control.Reference ( module Control.Reference.InternalInterface -, module Control.Reference.Predefined.Containers.Tree , module Control.Reference.TH.Records , module Control.Reference.TupleInstances ) where diff --git a/Control/Reference/Combinators.hs b/Control/Reference/Combinators.hs --- a/Control/Reference/Combinators.hs +++ b/Control/Reference/Combinators.hs @@ -6,8 +6,6 @@ import Control.Reference.Representation import Control.Instances.Morph import Control.Monad -import Control.Monad.Identity -import Control.Applicative -- * Binary operators on references @@ -19,11 +17,11 @@ -- Composition is associative: @ (r&p)&q = r&(p&q) @ (&) :: (Monad w, Monad r) => Reference w r w' r' s t c d -> Reference w r w' r' c d a b -> Reference w r w' r' s t a b -(&) l1 l2 = Reference (refGet l1 . refGet l2) - (refUpdate l1 . refSet l2) +(&) l1 l2 = Reference (refGet l1 . refGet l2) + (refUpdate l1 . refSet l2) (refUpdate l1 . refUpdate l2) (refGet' l2 . refGet' l1) - (refUpdate' l2 . refSet' l1) + (refUpdate' l2 . refSet' l1) (refUpdate' l2 . refUpdate' l1) infixl 6 & @@ -42,27 +40,27 @@ (&+&) :: (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) +l1 &+& l2 = Reference (\f a -> refGet l1 f a `mplus` refGet l2 f a) (\v -> refSet l1 v >=> refSet l2 v ) (\trf -> refUpdate l1 trf >=> refUpdate l2 trf ) - (\f a -> refGet' l1 f a `mplus` refGet' l2 f a) + (\f a -> refGet' l1 f a `mplus` refGet' l2 f a) (\v -> refSet' l1 v >=> refSet' l2 v ) (\trf -> refUpdate' l1 trf >=> refUpdate' l2 trf ) infixl 5 &+& -- | Pack two references in parallel. -(&|&) :: (RefMonads m m') - => Reference m m m' m' s t a b -> Reference m m m' m' s' t' a' b' +(&|&) :: (RefMonads m m') + => Reference m m m' m' s t a b -> Reference m m m' m' s' t' a' b' -> Reference m m m' m' (s, s') (t, t') (a, a') (b, b') -r1 &|& r2 = Reference (\f (s1,s2) -> ((,) <$> refGet r1 return s1 <*> refGet r2 return s2) >>= f) - (\(b1,b2) (s1,s2) -> (,) <$> refSet r1 b1 s1 <*> refSet r2 b2 s2) +r1 &|& r2 = Reference (\f (s1,s2) -> ((,) <$> refGet r1 return s1 <*> refGet r2 return s2) >>= f) + (\(b1,b2) (s1,s2) -> (,) <$> refSet r1 b1 s1 <*> refSet r2 b2 s2) (\f (s1,s2) -> do a1 <- refGet r1 return s1 a2 <- refGet r2 return s2 t1 <- refUpdate r1 (liftM fst . flip (curry f) a2) s1 t2 <- refUpdate r2 (liftM snd . curry f a1) s2 - return (t1, t2) ) + return (t1, t2) ) (\f (s1,s2) -> ((,) <$> refGet' r1 return s1 <*> refGet' r2 return s2) >>= f) (\(b1,b2) (s1,s2) -> (,) <$> refSet' r1 b1 s1 <*> refSet' r2 b2 s2) (\f (s1,s2) -> do a1 <- refGet' r1 return s1 @@ -73,7 +71,7 @@ infixl 5 &|& - + -- | 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 diff --git a/Control/Reference/Operators.hs b/Control/Reference/Operators.hs --- a/Control/Reference/Operators.hs +++ b/Control/Reference/Operators.hs @@ -6,7 +6,7 @@ -- | Common operators for using references. -- -- There are four kinds of operator for every type of reference. --- The operators are either getters ('^.' and '^?'), setters ('.=' and '!='), +-- The operators are either getters ('^.' and '^?'), setters ('.=' and '!='), -- monadic updaters ('.~' and '!~'), pure updaters ('.-' and '!-') or action performers ('!|'). -- -- 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 @Just 4@). @@ -17,11 +17,7 @@ import Control.Reference.Types import Control.Reference.Combinators -import Control.Instances.Morph -import Control.Applicative import Control.Monad.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.List -- * Getters @@ -34,7 +30,7 @@ (^?) :: Monad m => s -> Getter m s t a b -> m a a ^? l = refGet l return a infixl 4 ^? - + -- | 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 diff --git a/Control/Reference/Predefined.hs b/Control/Reference/Predefined.hs --- a/Control/Reference/Predefined.hs +++ b/Control/Reference/Predefined.hs @@ -16,13 +16,10 @@ import Control.Reference.Operators import Control.Instances.Morph -import Control.Applicative import Control.Monad import Data.Ratio import qualified Data.Text as Text import Data.Complex -import Control.Monad.Identity -import Control.Monad.Writer import Control.Monad.State import Control.Concurrent.MVar hiding (modifyMVarMasked_) import Control.Concurrent.Chan @@ -41,7 +38,7 @@ -- -- > self & a = a & self = a self :: Lens a b a b -self = reference return (const . return) id +self = reference return (const . return) id -- | An empty reference that do not traverse anything -- @@ -60,12 +57,12 @@ -- | A partial lens to access the value that may not exist just :: Prism (Maybe a) (Maybe b) a b just = prism Just Just (maybe (Left Nothing) Right) id - + -- | A partial lens to access the right option of an 'Either' right :: Prism (Either a b) (Either a c) b c right = prism Right Right (either (Left . Left) Right) rightToMaybe - --- | A partial lens to access the left option of an 'Either' + +-- | A partial lens to access the left option of an 'Either' left :: Prism (Either a c) (Either b c) a b left = prism Left Left (either Right (Left . Right)) leftToMaybe @@ -77,14 +74,14 @@ -- | References both elements of a tuple both :: Traversal (a,a) (b,b) a b -both = reference (\(x,y) -> morph [x,y]) - (\v -> return . const (v,v)) +both = reference (\(x,y) -> morph [x,y]) + (\v -> return . const (v,v)) (\f (x,y) -> (,) <$> f x <*> f y) -- | References the head of a list atHead :: Simple Lens [a] (Maybe a) atHead = lens (\case [] -> Nothing; x:_ -> Just x) - (\case Nothing -> drop 1; + (\case Nothing -> drop 1; Just v -> \case [] -> [v] _:xs -> v:xs) @@ -100,7 +97,7 @@ dropped :: Int -> Simple Partial [a] [a] dropped 0 = self dropped i = _tail & dropped (i-1) - + -- | Views a list as an optinal pair view :: Iso [a] [b] (Maybe (a,[a])) (Maybe (b,[b])) view = iso' to to from from @@ -110,37 +107,37 @@ from :: Maybe (x,[x]) -> [x] from Nothing = [] from (Just (x,xs)) = x:xs - + -- | An isomorphism between the list and text representation of a string -text :: Simple Iso String Text.Text -text = iso Text.pack Text.unpack - +text :: Simple Iso String Text.Text +text = iso Text.pack Text.unpack + -- | Accesses the reversed version of a list -- -- > 'turn' reversed == reversed reversed :: Iso [a] [b] [a] [b] -reversed = iso' reverse reverse reverse reverse - +reversed = iso' reverse reverse reverse reverse + -- | Accesses the numerator of a ratio _numerator :: Integral a => Simple Lens (Ratio a) a -_numerator = lens numerator (\num' r -> num' % denominator r) +_numerator = lens numerator (\num' r -> num' % denominator r) -- | Accesses the denominator of a ratio _denominator :: Integral a => Simple Lens (Ratio a) a -_denominator = lens denominator (\denom' r -> numerator r % denom') - +_denominator = lens denominator (\denom' r -> numerator r % denom') + -- | Accesses the real part of a complex number _realPart :: RealFloat a => Simple Lens (Complex a) a -_realPart = lens realPart (\real' c -> real' :+ imagPart c) +_realPart = lens realPart (\real' c -> real' :+ imagPart c) -- | Accesses the imaginary part of a complex number _imagPart :: RealFloat a => Simple Lens (Complex a) a -_imagPart = lens imagPart (\imag' c -> realPart c :+ imag') - +_imagPart = lens imagPart (\imag' c -> realPart c :+ imag') + -- | Accesses the polar representation of a complex number _polar :: RealFloat a => Simple Lens (Complex a) (a, a) _polar = iso polar (uncurry mkPolar) - + -- * Stateful references -- | A dummy object to interact with the user through the console. @@ -149,11 +146,11 @@ -- | 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 +consoleLine + = reference (const (morph getLine)) + (\str -> const (morph (putStrLn str) >> return Console)) + (\f -> const (morph getLine >>= f + >>= morph . putStrLn >> return Console)) -- | Reference to the contents of the file. Not thread-safe. @@ -162,50 +159,50 @@ -- -- Creates a temporary file to store the result. fileContent :: Simple IOLens FilePath (Maybe String) -fileContent +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 + `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 + `Ex.catch` \e -> if isDoesNotExistError e then return Nothing else Ex.throw e - case h of + 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 :: 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) + 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 + (\(_,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 -- value, one may block and can corrupt the following updates. -- -- Reads and updates are done in sequence, always using consistent data. mvar :: Simple IOLens (MVar a) a -mvar = rawReference +mvar = rawReference (\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) + (\trf mv -> modifyMVarMasked_ mv trf >> return mv) unusableOp unusableOp unusableOp -- | Generalized version of 'Control.Concurrent.MVar.modifyMVarMasked_'. @@ -223,37 +220,36 @@ -- | 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) (\trf ch -> morph (readChan ch) >>= trf >>= morph . writeChan ch >> return ch) - --- | Access the value of an IORef. + +-- | Access the value of an IORef. ioref :: Simple IOLens (IORef a) a ioref = reference (morph . readIORef) - (\v ior -> morph (atomicWriteIORef ior v) >> return ior) + (\v ior -> morph (atomicWriteIORef ior v) >> return ior) (\trf ior -> morph (readIORef ior) - >>= trf >>= morph . writeIORef ior >> return ior) - + >>= trf >>= morph . writeIORef ior >> return ior) + -- | Access the state inside a state monad (from any context). 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) +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 - + -- | Access the value inside an 'STRef' stRef :: Simple (STLens s) (STRef s a) a stRef = reference (morph . readSTRef) (\newVal ref -> morph $ writeSTRef ref newVal >> return ref) - (\trf ref -> morph (readSTRef ref) >>= trf - >>= morph . writeSTRef ref >> return ref) - + (\trf ref -> morph (readSTRef ref) >>= trf + >>= morph . writeSTRef ref >> return ref) + -- | Filters an indexed reference based on the index -whereOf :: (RefMonads w r, MonadPlus r) +whereOf :: (RefMonads w r, MonadPlus r) => (i -> Bool) -> (IndexedReference i w r MU MU s s a a) -> (IndexedReference i w r MU MU s s a a) whereOf p iref i | p i = iref i | otherwise = emptyRef - diff --git a/Control/Reference/Predefined/Containers.hs b/Control/Reference/Predefined/Containers.hs --- a/Control/Reference/Predefined/Containers.hs +++ b/Control/Reference/Predefined/Containers.hs @@ -9,7 +9,7 @@ import Control.Reference.Types import Control.Reference.Generators import Control.Reference.Operators - + import Control.Instances.Morph import Data.Map as Map import qualified Data.Array as Arr @@ -18,15 +18,15 @@ 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 + +instance Association [a] where type AssocIndex [a] = Int type AssocElem [a] = a element i = reference (morph . at i) (\v -> upd (const (return v))) upd @@ -35,13 +35,13 @@ 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) = Prelude.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 + +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 @@ -54,22 +54,22 @@ = f (arr Arr.! i) >>= \v -> return (arr Arr.// [(i,v)]) | otherwise = return arr -instance Association (Seq.Seq a) where +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))) + element i = reference (morph . at) (\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 - + where at :: Seq.Seq a -> Maybe a + at 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 + 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 @@ -78,79 +78,79 @@ 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 + 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 + +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) - + 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) + (\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) + (\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)) - + 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 + (\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) + (\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)) - + 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 + 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 + (\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 + 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 + (\trf s -> trf (IS.member e s) >>= return . \case True -> IS.insert e s - False -> IS.delete e s) + False -> IS.delete e s) diff --git a/Control/Reference/Representation.hs b/Control/Reference/Representation.hs --- a/Control/Reference/Representation.hs +++ b/Control/Reference/Representation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ConstraintKinds #-} -- | This module declares the representation and basic classes of references. @@ -10,12 +10,11 @@ module Control.Reference.Representation where import Data.Proxy -import Control.Applicative --- | A reference is an accessor to a part or different view of some data. +-- | 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, -- the semantics are a bit different --- + -- == Reference laws -- -- As the references are generalizations of lenses, they should conform to the lens laws: @@ -39,7 +38,7 @@ -- @ -- -- But because update, set and get are different operations, . --- +-- -- 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): -- -- @ @@ -51,7 +50,7 @@ -- == 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. +-- ['r'] Reader monad. Controls how part of the value can be asked. -- See differences between 'Lens', 'Partial' and 'Traversal' -- [@w'@] Backward writer monad. See 'turn' -- [@r'@] Backward reader monad. See 'turn' @@ -67,19 +66,19 @@ -- data Reference w r w' r' s t a b - = Reference { refGet :: forall x . (a -> r x) -> s -> r x + = 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 + , refUpdate :: (a -> w b) -> s -> w t -- ^ Updater for the lens. Handles monadic update functions. , refGet' :: forall x . (s -> r' x) -> a -> r' x , refSet' :: t -> a -> w' b , refUpdate' :: (s -> w' t) -> a -> w' b } - + type IndexedReference i w r w' r' s t a b = i -> Reference w r w' r' s t a b -- Creates a two-way reference @@ -92,16 +91,16 @@ -> ((s -> w' t) -> a -> w' b) -- ^ Backward updater -> Reference w r w' r' s t a b bireference get set upd get' set' upd' - = Reference (\f s -> get s >>= f) set upd + = Reference (\f s -> get s >>= f) set upd (\f s -> get' s >>= f) set' upd' - + -- | Creates a reference. -reference :: ( RefMonads w r ) +reference :: ( RefMonads w r ) => (s -> r a) -- ^ Getter -> (b -> s -> w t) -- ^ Setter -> ((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 +reference gets sets updates = Reference (\f s -> gets s >>= f) sets updates unusableOp unusableOp unusableOp -- | Creates a reference where all operations are added in their original form. @@ -117,12 +116,11 @@ -> ((s -> w' t) -> a -> w' b) -- ^ Backward updater -> Reference w r w' r' s t a b rawReference = Reference - + -- | Creates a reference with explicit close operations that are executed -- after the data is accessed. referenceWithClose - :: ( Functor w, Applicative w, Monad w - , Functor r, Applicative r, Monad r ) + :: RefMonads w r => (s -> r a) -- ^ Getter -> (s -> r ()) -- ^ Close after getting -> (b -> s -> w t) -- ^ Setter @@ -135,18 +133,14 @@ (\b s -> set b s <* setClose s) (\trf s -> update trf s <* updateClose s) 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 - , 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 - +type RefMonads w r = ( Functor w, Applicative w, Monad w + , Functor r, Applicative r, Monad r + ) + type MU = Proxy unusableOp :: a -> b -> MU c unusableOp _ _ = Proxy - diff --git a/Control/Reference/TH/Records.hs b/Control/Reference/TH/Records.hs --- a/Control/Reference/TH/Records.hs +++ b/Control/Reference/TH/Records.hs @@ -9,7 +9,7 @@ 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 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: @@ -28,7 +28,7 @@ @ 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')) @@ -51,7 +51,6 @@ import Control.Monad.Writer import Control.Monad.Trans.State -import Control.Instances.Morph import Control.Reference.InternalInterface import Control.Reference.Examples.TH import Control.Reference.TupleInstances @@ -62,136 +61,136 @@ -- | Creates references for fields of a data structure. makeReferences :: Name -> Q [Dec] -makeReferences n +makeReferences n = do inf <- reify n case inf of TyConI decl -> case newtypeToData decl of - DataD _ tyConName args _ cons _ -> + DataD _ tyConName args _ cons _ -> createReferences tyConName (args ^? traversal&typeVarName) cons _ -> fail "makeReferences: Unsupported data type" _ -> fail "makeReferences: Expected the name of a data type or newtype" - + createReferences :: Name -> [Name] -> [Con] -> Q [Dec] createReferences tyConName args cons = let toGenerate = group $ sortBy (compare `on` fst) $ concat $ map getConFlds cons -- only those type vars are mutable that appear in at most once in all of the constructors mutableVars = foldl (\a (_,t) -> foldl (flip delete) a (t ^? typeVariableNames :: [Name])) (args++args) (map head toGenerate) -- those references will be complete that are generated from fields that are present in every constructor - (complete, partials) - = partition ((length cons ==) . length) + (complete, partials) + = partition ((length cons ==) . length) $ toGenerate - in do comps <- mapM (createLensForField tyConName args mutableVars . head) complete - parts <- mapM (createPartialLensForField tyConName args mutableVars cons . head) partials + in do comps <- mapM (createLensForField tyConName args mutableVars . head) complete + parts <- mapM (createPartialLensForField tyConName args mutableVars cons . head) partials return $ concat (comps ++ parts) - where getConFlds con@(RecC conName conFields) = map (\(n,_,t) -> (n, t)) conFields - getConFlds _ = [] - + where getConFlds (RecC _ conFields) = map (\(n,_,t) -> (n, t)) conFields + getConFlds _ = [] + createLensForField :: Name -> [Name] -> [Name] -> (Name,Type) -> Q [Dec] -createLensForField typName typArgs mutArgs (fldName,fldTyp) - = do lTyp <- referenceType (ConT ''Lens) typName typArgs mutArgs fldTyp +createLensForField typName typArgs mutArgs (fldName,fldTyp) + = do lTyp <- referenceType (ConT ''Lens) typName typArgs mutArgs fldTyp lensBody <- genLensBody return [ SigD lensName lTyp , ValD (VarP lensName) (NormalB $ lensBody) [] - ] + ] where lensName = refName fldName - + genLensBody :: Q Exp - genLensBody + genLensBody = do setVar <- newName "b" origVar <- newName "s" - return $ VarE 'lens - `AppE` VarE fldName - `AppE` LamE [VarP setVar, VarP origVar] + return $ VarE 'lens + `AppE` VarE fldName + `AppE` LamE [VarP setVar, VarP origVar] (RecUpdE (VarE origVar) [(fldName,VarE setVar)]) - + createPartialLensForField :: Name -> [Name] -> [Name] -> [Con] -> (Name,Type) -> Q [Dec] createPartialLensForField typName typArgs mutArgs cons (fldName,fldTyp) - = do lTyp <- referenceType (ConT ''Partial) typName typArgs mutArgs fldTyp + = do lTyp <- referenceType (ConT ''Partial) typName typArgs mutArgs fldTyp lensBody <- genLensBody return [ SigD lensName lTyp , ValD (VarP lensName) (NormalB $ lensBody) [] - ] + ] where lensName = refName fldName - + genLensBody :: Q Exp - genLensBody - = do matchesWithField <- mapM matchWithField consWithField + genLensBody + = do matchesWithField <- mapM matchWithField consWithField matchesWithoutField <- mapM matchWithoutField consWithoutField name <- newName "x" - return $ VarE 'partial + return $ VarE 'partial `AppE` LamE [VarP name] (CaseE (VarE name) ( matchesWithField ++ matchesWithoutField )) - - (consWithField, consWithoutField) + + (consWithField, consWithoutField) = partition (hasField fldName) cons - + matchWithField :: Con -> Q Match - matchWithField con + matchWithField con = do (bind, rebuild, vars) <- bindAndRebuild con setVar <- newName "b" let Just bindInd = fieldIndex fldName con - bindRight - = ConE 'Right + bindRight + = ConE 'Right `AppE` TupE [ VarE (vars !! bindInd) - , LamE [VarP setVar] + , LamE [VarP setVar] (funApplication & element (bindInd+1) .= VarE setVar $ rebuild) ] return $ Match bind (NormalB bindRight) [] - + matchWithoutField :: Con -> Q Match - matchWithoutField con + matchWithoutField con = do (bind, rebuild, _) <- bindAndRebuild con - return $ Match bind (NormalB (ConE 'Left `AppE` rebuild)) [] + return $ Match bind (NormalB (ConE 'Left `AppE` rebuild)) [] -- | Creates the type of the reference being defined referenceType :: Type -> Name -> [Name] -> [Name] -> Type -> Q Type -referenceType refType name args mutArgs fldTyp +referenceType refType name args mutArgs fldTyp = do (fldTyp',mapping) <- makePoly mutArgs fldTyp let args' = traversal .- (\a -> fromMaybe a (mapping ^? element a)) $ args - return $ ForallT (map PlainTV (sort (nub (M.elems mapping ++ args)))) [] - (refType `AppT` addTypeArgs name args - `AppT` addTypeArgs name args' - `AppT` fldTyp - `AppT` fldTyp') - + return $ ForallT (map PlainTV (sort (nub (M.elems mapping ++ args)))) [] + (refType `AppT` addTypeArgs name args + `AppT` addTypeArgs name args' + `AppT` fldTyp + `AppT` fldTyp') + -- | Creates a new field type with changing the type variables that are bound outside makePoly :: [Name] -> Type -> Q (Type, M.Map Name Name) -makePoly typArgs fldTyp - = runStateT (typVarsBounded !~ updateName $ fldTyp) M.empty +makePoly typArgs fldTyp + = runStateT (typVarsBounded !~ updateName $ fldTyp) M.empty where typVarsBounded :: Simple Traversal Type Name typVarsBounded = typeVariableNames & filtered (`elem` typArgs) - updateName name = do name' <- lift (newName (nameBase name ++ "'")) + updateName name = do name' <- lift (newName (nameBase name ++ "'")) modify (M.insert name name') return name' - - - + + + -- | Dictates what reference names should be generated from field names refName :: Name -> Name refName = nameBaseStr .- \case '_':xs -> xs; xs -> '_':xs --- * Helper functions +-- * Helper functions hasField :: Name -> Con -> Bool hasField n c = not $ null (c ^? recFields & traversal & _1 & filtered (==n) :: [Name]) - + fieldIndex :: Name -> Con -> Maybe Int fieldIndex n con = (con ^? recFields) >>= findIndex (\f -> (f ^. _1) == n) - + -- | Creates a type from applying binded type variables to a type function addTypeArgs :: Name -> [Name] -> Type addTypeArgs n = foldl AppT (ConT n) . map VarT - + newtypeToData :: Dec -> Dec -newtypeToData (NewtypeD ctx name tvars kind con derives) +newtypeToData (NewtypeD ctx name tvars kind con derives) = DataD ctx name tvars kind [con] derives newtypeToData d = d bindAndRebuild :: Con -> Q (Pat, Exp, [Name]) -bindAndRebuild con +bindAndRebuild con = do let name = con ^. conName fields = con ^. conFields bindVars <- replicateM (length fields) (newName "fld") @@ -200,5 +199,5 @@ , bindVars ) -instance Morph (StateT s m) (StateT s m) where - morph = id +-- instance GenMorph DB (StateT s m) (StateT s m) where +-- genMorph _ = id diff --git a/Control/Reference/TH/Tuple.hs b/Control/Reference/TH/Tuple.hs --- a/Control/Reference/TH/Tuple.hs +++ b/Control/Reference/TH/Tuple.hs @@ -1,41 +1,40 @@ {-# LANGUAGE TemplateHaskell #-} --- | A module for creating lenses to fields of simple, tuple data structures +-- | A module for creating lenses to fields of simple, tuple data structures -- like pairs, triplets, and so on. module Control.Reference.TH.Tuple (TupleConf(..), hsTupConf, makeTupleRefs) where import Language.Haskell.TH import Control.Monad -import Control.Applicative import Data.Maybe import Control.Reference.InternalInterface -- | Creates @Lens_1@ ... @Lens_n@ classes, and instances for tuples up to 'm'. --- +-- -- Classes and instances look like the following: --- +-- -- @ -- class Lens_1 s t a b | s -> a, t -> b --- , a t -> s, b s -> t where +-- , a t -> s, b s -> t where -- _1 :: Lens s t a b -- --- instance Lens_1 (a,b) (a',b) a a' where +-- instance Lens_1 (a,b) (a',b) a a' where -- _1 = lens (\(a,b) -> a) (\a' (a,b) -> (a',b)) -- @ -- makeTupleRefs :: TupleConf -> Int -> Int -> Q [Dec] -makeTupleRefs conf n m - = (++) <$> (catMaybes <$> genClass `mapM` [0..(n-1)]) - <*> (genInstance conf +makeTupleRefs conf n m + = (++) <$> (catMaybes <$> genClass `mapM` [0..(n-1)]) + <*> (genInstance conf `mapM` [ (x, y) | x <- [0..(n-1)] - , y <- [(max 2 (x+1))..m] ]) + , y <- [(max 2 (x+1))..m] ]) genClass :: Int -> Q (Maybe Dec) -genClass i +genClass i = do declared <- classDeclared i if declared then return Nothing else Just <$> genClass' i - where genClass' i = + where genClass' i = do s <- newName "s" t <- newName "t" a <- newName "a" @@ -43,15 +42,18 @@ let tvars = map PlainTV [s,t,a,b] return $ ClassD [] (lensClass i) tvars [ FunDep [s] [a], FunDep [t] [b] - , FunDep [a,t] [s], FunDep [b,s] [t]] - [ SigD (lensFun i) - (foldl AppT (ConT ''Lens) (map VarT [s,t,a,b])) - ] + , FunDep [a,t] [s], FunDep [b,s] [t]] + [ SigD (lensFun i) + (foldl AppT (ConT ''Lens) (map VarT [s,t,a,b])) + ] +lensClass :: Int -> Name lensClass i = mkName ("Lens_" ++ show (i+1)) + +lensFun :: Int -> Name lensFun i = mkName ("_" ++ show (i+1)) - -classDeclared :: Int -> Q Bool + +classDeclared :: Int -> Q Bool classDeclared i = isJust <$> lookupTypeName (nameBase $ lensClass i) genInstance :: TupleConf -> (Int,Int) -> Q Dec @@ -59,24 +61,24 @@ = do names <- replicateM m (newName "a") name <- newName "b2" genBody <- generateBody - return $ InstanceD Nothing [] - (ConT (lensClass n) + return $ InstanceD Nothing [] + (ConT (lensClass n) `AppT` typGen names `AppT` typGen (replace n name names) `AppT` VarT (names !! n) `AppT` VarT name - ) - [ ValD (VarP (lensFun n) ) + ) + [ ValD (VarP (lensFun n) ) (NormalB genBody) [] ] where generateBody :: Q Exp generateBody = do names <- replicateM m (newName "a") name <- newName "b3" - return $ VarE 'lens - `AppE` LamE [patGen names] + return $ VarE 'lens + `AppE` LamE [patGen names] (VarE (names !! n)) - `AppE` LamE [VarP name, patGen names] + `AppE` LamE [VarP name, patGen names] (expGen (replace n name names)) -- | A tuple configuration is a scheme for tuple-like data structures. @@ -84,17 +86,17 @@ , tuplePattern :: [Name] -> Pat , tupleExpr :: [Name] -> Exp } - --- | Generates the normal haskell tuples (@(a,b), (a,b,c), (a,b,c,d)@) -hsTupConf - = TupleConf (\names -> foldl AppT (TupleT (length names)) . map VarT $ names) - (TupP . map VarP) + +-- | Generates the normal haskell tuples (@(a,b), (a,b,c), (a,b,c,d)@) +hsTupConf :: TupleConf +hsTupConf + = TupleConf (\names -> foldl AppT (TupleT (length names)) . map VarT $ names) + (TupP . map VarP) (TupE . map VarE) - --- | Utility function to replace the N'th element of a list + +-- | Utility function to replace the N'th element of a list replace :: Int -> a -> [a] -> [a] -replace i e ls - = let (before,after) = splitAt i ls - in case after of [] -> error $ "replace : Index " ++ show i ++ " is not found." +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 - diff --git a/Control/Reference/TupleInstances.hs b/Control/Reference/TupleInstances.hs --- a/Control/Reference/TupleInstances.hs +++ b/Control/Reference/TupleInstances.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -w #-} + {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} @@ -9,4 +11,3 @@ import Control.Reference.TH.Tuple $(makeTupleRefs hsTupConf 16 16) - diff --git a/Control/Reference/Types.hs b/Control/Reference/Types.hs --- a/Control/Reference/Types.hs +++ b/Control/Reference/Types.hs @@ -1,27 +1,25 @@ {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies #-} {-# LANGUAGE KindSignatures, MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, ConstraintKinds #-} -- | This module defines the polymorphic types of the created references. -- The actual type of a reference can be different for every usage, -- the polymorphic type gives a lower bound on the actual one. module Control.Reference.Types where - + import Control.Reference.Representation - + import Control.Instances.Morph -import Control.Applicative import Control.Monad import Control.Monad.State (StateT) import Control.Monad.Writer (WriterT) -import Control.Monad.Identity (Identity(..)) import Control.Monad.Trans.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.ST (ST) import Data.Proxy - --- | A monomorph 'Lens', 'Traversal', 'Partial', etc... + +-- | 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 @@ -32,19 +30,19 @@ 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. -- Can be used to access the same data in two different representations. type Iso s t a b = forall w r w' r' . (RefMonads w r, RefMonads w' r') => Reference w r w' r' s t a b - --- | A partial lens that can be turned to get a total lens. + +-- | 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, Morph Maybe r - , MonadPlus w', Morph 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. -- A 'Lens' can have any read and write semantics that a 'Reference' can have. type Lens s t a b @@ -55,7 +53,7 @@ type RefPlus s t a b = forall w r . ( RefMonads w r, MonadPlus r ) => Reference w r MU MU s t a b - + -- | Partial lens. A 'Reference' that can access data that may not exist in the context. -- Every lens is a partial lens. -- @@ -66,10 +64,10 @@ = forall w r . ( Functor w, Applicative w, Monad w , Functor r, Applicative r, MonadPlus r, Morph Maybe r ) => Reference w r MU MU s t a b - + -- | 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. @@ -79,10 +77,8 @@ -- * References for 'IO' -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 +type IOMonads w r = ( Morph IO w, Morph IO r + , MorphControl IO w, MorphControl IO r ) -- | A reference that can access mutable data. type IOLens s t a b @@ -156,41 +152,40 @@ => Reference w r MU MU s t a b -- | A class for representing calculation in a simpler monad. --- +-- -- @pullBack . sink === id@ class MorphControl (m1 :: * -> *) (m2 :: * -> *) where data MSt m1 m2 a :: * sink :: m2 a -> m1 (MSt m1 m2 a) pullBack :: m1 (MSt m1 m2 a) -> m2 a - + instance Monad m => MorphControl m (MaybeT m) where newtype MSt m (MaybeT m) a = MaybeMSt { fromMaybeMSt :: Maybe a } sink = liftM MaybeMSt . runMaybeT pullBack = MaybeT . liftM fromMaybeMSt - + instance Monad m => MorphControl m (ListT m) where newtype MSt m (ListT m) a = ListMSt { fromListMSt :: [a] } sink = liftM ListMSt . runListT pullBack = ListT . liftM fromListMSt - + -- FIXME: conflicts with other instance declarations -- instance (Monad m, Morph m m) => MorphControl m m where -- newtype MSt m m a = ReflMSt { fromReflMSt :: a } -- sink = liftM ReflMSt -- pullBack = liftM fromReflMSt - + instance MorphControl IO IO where newtype MSt IO IO a = ReflIOMSt { fromReflIOMSt :: a } sink = liftM ReflIOMSt pullBack = liftM fromReflIOMSt - + -- instance MorphControl Identity m where -- newtype MSt Identity m a = IdMSt { fromIdMSt :: m a } -- sink = Identity . IdMSt -- pullBack = fromIdMSt . runIdentity - + instance (Monad m) => MorphControl m MU where newtype MSt m MU a = ProxyMSt () sink _ = return (ProxyMSt ()) pullBack _ = Proxy - diff --git a/references.cabal b/references.cabal --- a/references.cabal +++ b/references.cabal @@ -1,5 +1,5 @@ name: references -version: 0.3.2.2 +version: 0.3.3.0 synopsis: Selectors for reading and updating data. 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>). @@ -92,6 +92,7 @@ location: git://github.com/lazac/references.git library + ghc-options: -Wall exposed-modules: Control.Reference , Control.Reference.Representation , Control.Reference.Types