polysemy-optics (empty) → 0.1.0.0
raw patch · 8 files changed
+321/−0 lines, 8 filesdep +basedep +opticsdep +polysemy
Dependencies added: base, optics, polysemy, polysemy-zoo
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.md +19/−0
- polysemy-optics.cabal +48/−0
- src/Optics/Polysemy.hs +33/−0
- src/Optics/Polysemy/Reader.hs +23/−0
- src/Optics/Polysemy/State.hs +146/−0
- src/Optics/Polysemy/Writer.hs +26/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for polysemy-optics++## 0.1.0.0 -- 2020-07-25++* Initial release.
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2020, Nicholas Coltharp++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,19 @@+Usage+=====++Simply import `Optics.Polysemy`. This serves as a drop-in replacement for+`Optics`, `Optics.State`, and `Optics.State.Operators`.++Caveats+=======++As best I can tell, the `zoom` functions cannot currently be translated with+complete precision. As a result, only a few `zoom` functions are present here,+and they behave a little strangely.+* If you use `zoom` or `zoomMaybe` to go from `State s` to `State a`, the+ original `State s` will still be present in your effect stack. Writes to the+ zoomed part of the `s` will be visible from inside the `State a`, and+ vice-versa.+* `zoomMany` cannot be sensibly implemented this way, so I have left it out.+* Due to difficulties with higher-order effects, I have not yet found a way to+ implement the `magnify` functions.
+ polysemy-optics.cabal view
@@ -0,0 +1,48 @@+cabal-version: 1.22++name: polysemy-optics+version: 0.1.0.0+synopsis: Optics for Polysemy.+description:+ Optics for interfacing with Reader, State, and Writer effects in Polysemy.+bug-reports: https://github.com/nosewings/polysemy-optics/issues+license: BSD2+license-file: LICENSE+author: Nicholas Coltharp+maintainer: coltharp@pdx.edu+copyright: 2020 Nicholas Coltharp+category: Optics, Lenses+build-type: Simple+extra-source-files: CHANGELOG.md+ , README.md++library+ exposed-modules: Optics.Polysemy+ other-modules: Optics.Polysemy.Reader+ , Optics.Polysemy.State+ , Optics.Polysemy.Writer+ reexported-modules: Optics+ , Optics.State.Operators+ build-depends: base >=4.12 && <4.14+ , optics >=0.1 && <0.4+ , polysemy >=0.4 && <1.4+ , polysemy-zoo >=0.6 && <0.8+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: BlockArguments+ , DataKinds+ , FlexibleContexts+ , LambdaCase+ , RankNTypes+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ ghc-options: -Weverything+ -Wno-implicit-prelude+ -Wno-missing-import-lists+ -Wno-missing-local-signatures+ -Wno-unsafe++source-repository head+ type: git+ location: https://github.com/nosewings/polysemy-optics
+ src/Optics/Polysemy.hs view
@@ -0,0 +1,33 @@+module Optics.Polysemy+ ( module Optics+ , module Optics.State.Operators+ , module Optics.Polysemy.Reader+ , module Optics.Polysemy.State+ , module Optics.Polysemy.Writer+ ) where++import Optics hiding+ ( Magnify(..)+ , Zoom(..)+ , assign+ , assign'+ , glistening+ , glistenings+ , guse+ , guses+ , gview+ , gviews+ , modifying+ , modifying'+ , preuse+ , use+ , zoom+ , zoomMaybe+ )+import Optics.State.Operators+ ( PermeableOptic(..)+ )++import Optics.Polysemy.Reader+import Optics.Polysemy.State+import Optics.Polysemy.Writer
+ src/Optics/Polysemy/Reader.hs view
@@ -0,0 +1,23 @@+module Optics.Polysemy.Reader+ ( gview+ , gviews+ ) where++import Optics+ ( Optic'+ , ViewResult+ , ViewableOptic+ )+import qualified Optics++import Polysemy+import Polysemy.Reader+import Polysemy.ConstraintAbsorber.MonadReader++gview :: (ViewableOptic k r, Member (Reader s) effs) => Optic' k is s r -> Sem effs (ViewResult k r)+gview o = absorbReader (Optics.gview o)+{-# INLINE gview #-}++gviews :: (ViewableOptic k r, Member (Reader s) effs) => Optic' k is s a -> (a -> r) -> Sem effs (ViewResult k r)+gviews o f = absorbReader (Optics.gviews o f)+{-# INLINE gviews #-}
+ src/Optics/Polysemy/State.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Optics.Polysemy.State+ ( modifying+ , modifying'+ , assign+ , assign'+ , use+ , preuse+ , (.=)+ , (?=)+ , (%=)+ , (%%=)+ , (<.=)+ , (<?=)+ , (<%=)+ , (<<.=)+ , (<<?=)+ , (<<%=)+ , guse+ , guses+ , zoom+ , zoomMaybe+ ) where++import Optics+ ( A_Getter+ , A_Lens+ , A_Setter+ , An_AffineFold+ , An_AffineTraversal+ , Is+ , Optic+ , Optic'+ , ViewResult+ , ViewableOptic+ , castOptic+ )+import qualified Optics+import qualified Optics.State+import Optics.State.Operators+ ( PermeableOptic+ )+import qualified Optics.State.Operators++import Polysemy+import Polysemy.State+import Polysemy.ConstraintAbsorber.MonadState++modifying :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> (a -> b) -> Sem effs ()+modifying o f = absorbState (Optics.State.modifying o f)+{-# INLINE modifying #-}++modifying' :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> (a -> b) -> Sem effs ()+modifying' o f = absorbState (Optics.State.modifying o f)+{-# INLINE modifying' #-}++assign :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> b -> Sem effs ()+assign o b = absorbState (Optics.State.assign o b)+{-# INLINE assign #-}++assign' :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> b -> Sem effs ()+assign' o b = absorbState (Optics.State.assign' o b)+{-# INLINE assign' #-}++use :: (Is k A_Getter, Member (State s) effs) => Optic' k is s a -> Sem effs a+use o = absorbState (Optics.State.use o)+{-# INLINE use #-}++preuse :: (Is k An_AffineFold, Member (State s) effs) => Optic' k is s a -> Sem effs (Maybe a)+preuse o = absorbState (Optics.State.preuse o)+{-# INLINE preuse #-}++infix 4 .=+(.=) :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> b -> Sem effs ()+o .= b = absorbState ((Optics.State.Operators..=) o b)+{-# INLINE (.=) #-}++infix 4 ?=+(?=) :: (Is k A_Setter, Member (State s) effs) => Optic k is s s (Maybe a) (Maybe b) -> b -> Sem effs ()+o ?= b = absorbState ((Optics.State.Operators.?=) o b)+{-# INLINE (?=) #-}++infix 4 %=+(%=) :: (Is k A_Setter, Member (State s) effs) => Optic k is s s a b -> (a -> b) -> Sem effs ()+o %= f = absorbState ((Optics.State.Operators.%=) o f)+{-# INLINE (%=) #-}++infix 4 %%=+(%%=) :: (PermeableOptic k r, Member (State s) effs) => Optic k is s s a b -> (a -> (r, b)) -> Sem effs (ViewResult k r)+o %%= f = absorbState ((Optics.State.Operators.%%=) o f)+{-# INLINE (%%=) #-}++infix 4 <.=+(<.=) :: (PermeableOptic k b, Member (State s) effs) => Optic k is s s a b -> b -> Sem effs (ViewResult k b)+o <.= b = absorbState ((Optics.State.Operators.<.=) o b)+{-# INLINE (<.=) #-}++infix 4 <?=+(<?=) :: (PermeableOptic k (Maybe b), Member (State s) effs) => Optic k is s s (Maybe a) (Maybe b) -> b -> Sem effs (ViewResult k (Maybe b))+o <?= b = absorbState ((Optics.State.Operators.<?=) o b)+{-# INLINE (<?=) #-}++infix 4 <%=+(<%=) :: (PermeableOptic k b, Member (State s) effs) => Optic k is s s a b -> (a -> b) -> Sem effs (ViewResult k b)+o <%= f = absorbState ((Optics.State.Operators.<%=) o f)+{-# INLINE (<%=) #-}++infix 4 <<.=+(<<.=) :: (PermeableOptic k a, Member (State s) effs) => Optic k is s s a b -> b -> Sem effs (ViewResult k a)+o <<.= b = absorbState ((Optics.State.Operators.<<.=) o b)+{-# INLINE (<<.=) #-}++infix 4 <<?=+(<<?=) :: (PermeableOptic k (Maybe a), Member (State s) effs) => Optic k is s s (Maybe a) (Maybe b) -> b -> Sem effs (ViewResult k (Maybe a))+o <<?= b = absorbState ((Optics.State.Operators.<<?=) o b)+{-# INLINE (<<?=) #-}++infix 4 <<%=+(<<%=) :: (PermeableOptic k a, Member (State s) effs) => Optic k is s s a b -> (a -> b) -> Sem effs (ViewResult k a)+o <<%= f = absorbState ((Optics.State.Operators.<<%=) o f)+{-# INLINE (<<%=) #-}++guse :: (ViewableOptic k a, Member (State s) effs) => Optic' k is s a -> Sem effs (ViewResult k a)+guse o = absorbState (Optics.guse o)+{-# INLINE guse #-}++guses :: (ViewableOptic k r, Member (State s) effs) => Optic' k is s a -> (a -> r) -> Sem effs (ViewResult k r)+guses o f = absorbState (Optics.guses o f)+{-# INLINE guses #-}++zoom :: (Is k A_Lens, Member (State s) effs) => Optic' k is s a -> Sem (State a ': effs) c -> Sem effs c+zoom o = interpret \case+ Get -> use o'+ Put a -> assign o' a+ where o' = castOptic @A_Lens o+{-# INLINE zoom #-}++zoomMaybe :: (Is k An_AffineTraversal, Member (State s) effs) => Optic' k is s a -> Sem (State a ': effs) c -> Sem effs (Maybe c)+zoomMaybe o m = preuse o' >>= traverse \a ->+ ( interpret \case+ Get -> maybe a id <$> preuse o'+ Put a' -> assign o' a'+ ) m+ where o' = castOptic @An_AffineTraversal o+{-# INLINE zoomMaybe #-}
+ src/Optics/Polysemy/Writer.hs view
@@ -0,0 +1,26 @@+module Optics.Polysemy.Writer+ ( glistening+ , glistenings+ ) where++import Optics+ ( Optic'+ , ViewResult+ , ViewableOptic+ )+import qualified Optics++import Polysemy+import Polysemy.Writer++glistening :: (ViewableOptic k r, Member (Writer s) effs) => Optic' k is s r -> Sem effs a -> Sem effs (a, ViewResult k r)+glistening o m = do+ (s, a) <- listen m+ return (a, Optics.gview o s)+{-# INLINE glistening #-}++glistenings :: (ViewableOptic k r, Member (Writer s) effs) => Optic' k is s a -> (a -> r) -> Sem effs b -> Sem effs (b, ViewResult k r)+glistenings o f m = do+ (s, b) <- listen m+ return (b, Optics.gviews o f s)+{-# INLINE glistenings #-}