Created
June 9, 2023 12:24
-
-
Save Lev135/c75f17bad0b6e2ad2e1fea09f0e34791 to your computer and use it in GitHub Desktop.
Effectful composible lens
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Control.Monad ((>=>)) | |
import Data.Map (Map) | |
import qualified Data.Map as M | |
import GHC.Generics (Generic) | |
import Optics | |
data MLens m s a = MLens | |
{ mview :: s -> m a | |
, mset :: a -> s -> m s | |
} | |
mover :: Monad m => MLens m s a -> (a -> m a) -> s -> m s | |
mover lens k s = do | |
a <- mview lens s | |
a' <- k a | |
mset lens a' s | |
(>%>) :: Monad m => MLens m s u -> MLens m u a -> MLens m s a | |
lsu >%> lua = MLens | |
{ mview = mview lsu >=> mview lua | |
, mset = \a s -> do | |
u <- mview lsu s | |
u' <- mset lua a u | |
mset lsu u' s | |
} | |
fromPrism :: (Is k An_AffineFold, Is k A_Setter) => | |
e -> Optic' k NoIx s a -> MLens (Either e) s a | |
fromPrism e p = MLens | |
{ mview = \s -> case preview p s of | |
Nothing -> Left e | |
Just a -> Right a | |
, mset = \a s -> case preview p s of | |
Nothing -> Left e | |
Just _ -> Right $ set p a s | |
} | |
data Tree | |
= Leaf | |
| Branch (Map String Tree) | |
deriving (Generic, Show) | |
data Err | |
= NotLeaf | |
| NotBranch | |
| NoChild String | |
deriving (Show) | |
leaf :: MLens (Either Err) Tree () | |
leaf = fromPrism NotLeaf #_Leaf | |
branch :: MLens (Either Err) Tree (Map String Tree) | |
branch = fromPrism NotBranch #_Branch | |
subtree :: String -> MLens (Either Err) Tree Tree | |
subtree name = branch >%> fromPrism (NoChild name) (ix name) | |
tree :: Tree | |
tree = Branch (M.fromList [("a", Leaf), ("b", Branch mempty)]) | |
{- | |
>>> mview (subtree "a") tree | |
Right Leaf | |
>>> mview (subtree "a" >%> leaf) tree | |
Right () | |
>>> mview (subtree "b" >%> leaf) tree | |
Left NotLeaf | |
>>> mview (subtree "b" >%> branch) tree | |
Right (fromList []) | |
>>> mset (subtree "b" >%> branch) (M.fromList [("x", Leaf)]) tree | |
Right (Branch (fromList [("a",Leaf),("b",Branch (fromList [("x",Leaf)]))])) | |
>>> mset (subtree "a" >%> branch) (M.fromList [("x", Leaf)]) tree | |
Left NotBranch | |
-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment