SHARE
TWEET

Optics.hs

Tysonzero Nov 16th, 2019 186 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE FlexibleInstances, RankNTypes #-}
  2.  
  3. module Optics where
  4.  
  5. import Control.Category (Category, (>>>))
  6. import qualified Control.Category as Cat
  7. import Control.Monad ((<=<))
  8. import Control.Monad.Identity (Identity(Identity), runIdentity)
  9. import Data.Function ((&))
  10. import Data.Functor.Const (Const(Const), getConst)
  11.  
  12. -- Lens
  13.  
  14. data Lens s a = Lens
  15.     { lGet :: s -> a
  16.     , lSet :: a -> s -> s
  17.     }
  18.  
  19. instance Category Lens where
  20.     id = Lens id const
  21.     l1 . l2 = Lens
  22.         { lGet = lGet l1 . lGet l2
  23.         , lSet = \x r -> lSet l2 (lSet l1 x (lGet l2 r)) r
  24.         }
  25.  
  26. class FromLens o where
  27.     fromLens :: Lens s a -> o s a
  28.  
  29. instance FromLens Lens where
  30.     fromLens = id
  31.  
  32. -- Getter
  33.  
  34. newtype Getter s a = Getter (s -> a)
  35.  
  36. instance Category Getter where
  37.     id = Getter id
  38.     Getter f . Getter g = Getter (f . g)
  39.  
  40. class FromLens o => FromGetter o where
  41.     fromGetter :: Getter s a -> o s a
  42.  
  43. instance FromGetter Getter where
  44.     fromGetter = id
  45.  
  46. instance FromLens Getter where
  47.     fromLens = Getter . lGet
  48.  
  49. (^.) :: s -> Getter s a -> a
  50. s ^. Getter f = f s
  51. infixl 8 ^.
  52.  
  53. to :: FromGetter o => (s -> a) -> o s a
  54. to = fromGetter . Getter
  55.  
  56. -- Traversal
  57.  
  58. newtype Traversal s a = Traversal (forall f. Applicative f => (a -> f a) -> s -> f s)
  59.  
  60. instance Category Traversal where
  61.     id = Traversal id
  62.     Traversal f . Traversal g = Traversal (g . f)
  63.  
  64. class FromLens o => FromTraversal o where
  65.     fromTraversal :: Traversal s a -> o s a
  66.  
  67. instance FromTraversal Traversal where
  68.     fromTraversal = id
  69.  
  70. instance FromLens Traversal where
  71.     fromLens l = Traversal (\f s -> (\x -> lSet l x s) <$> f (lGet l s))
  72.  
  73. -- Fold
  74.  
  75. newtype Fold s a = Fold (s -> [a])
  76.  
  77. instance Category Fold where
  78.     id = Fold pure
  79.     Fold f . Fold g = Fold (f <=< g)
  80.  
  81. class (FromGetter o, FromTraversal o) => FromFold o where
  82.     fromFold :: Fold s a -> o s a
  83.  
  84. instance FromFold Fold where
  85.     fromFold = id
  86.  
  87. instance FromGetter Fold where
  88.     fromGetter (Getter g) = Fold (pure . g)
  89.  
  90. instance FromTraversal Fold where
  91.     fromTraversal (Traversal t) = Fold (getConst . t (Const . pure))
  92.  
  93. instance FromLens Fold where
  94.     fromLens = fromGetter . fromLens
  95.  
  96. (^..) :: s -> Fold s a -> [a]
  97. s ^.. Fold f = f s
  98. infixl 8 ^..
  99.  
  100. -- Setter
  101.  
  102. newtype Setter s a = Setter ((a -> a) -> s -> s)
  103.  
  104. instance Category Setter where
  105.     id = Setter id
  106.     Setter f . Setter g = Setter (g . f)
  107.  
  108. class FromTraversal o => FromSetter o where
  109.     fromSetter :: Setter s a -> o s a
  110.  
  111. instance FromSetter Setter where
  112.     fromSetter = id
  113.  
  114. instance FromTraversal Setter where
  115.     fromTraversal (Traversal t) = Setter (\f -> runIdentity . t (Identity . f))
  116.  
  117. instance FromLens Setter where
  118.     fromLens l = Setter (\f s -> lSet l (f (lGet l s)) s)
  119.  
  120. (%~) :: Setter s a -> (a -> a) -> s -> s
  121. Setter f %~ g = f g
  122. infixr 4 %~
  123.  
  124. (.~) :: Setter s a -> a -> s -> s
  125. s .~ x = s %~ const x
  126. infixr 4 .~
  127.  
  128. sets :: FromSetter o => ((a -> a) -> s -> s) -> o s a
  129. sets = fromSetter . Setter
  130.  
  131. -- Implementations
  132.  
  133. _1 :: FromLens o => o (a, b) a
  134. _1 = fromLens $ Lens
  135.     { lGet = fst
  136.     , lSet = \x (_, y) -> (x, y)
  137.     }
  138.  
  139. _2 :: FromLens o => o (a, b) b
  140. _2 = fromLens $ Lens
  141.     { lGet = snd
  142.     , lSet = \y (x, _) -> (x, y)
  143.     }
  144.  
  145. _Just :: FromTraversal o => o (Maybe a) a
  146. _Just = fromTraversal $ Traversal traverse
  147.  
  148. _Left :: FromTraversal o => o (Either a b) a
  149. _Left = fromTraversal $ Traversal traverseLeft
  150.   where
  151.     traverseLeft f (Left l) = Left <$> f l
  152.     traverseLeft f s@(Right _) = pure s
  153.  
  154. _Right :: FromTraversal o => o (Either a b) b
  155. _Right = fromTraversal $ Traversal traverse
  156.  
  157. -- Examples
  158.  
  159. five :: Int
  160. five = (5, 1) ^. _1
  161.  
  162. left6 :: Either Int Bool
  163. left6 = Left 5 & _Left %~ (+ 1)
  164.  
  165. seven :: Int
  166. seven = (6, (7, 8)) ^. (_2 >>> _1)
  167.  
  168. one8 :: [Int]
  169. one8 = (1, Just 8) ^.. (_2 >>> _Just)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top