Modified external interface of LensInternal module
Getty Ritter
9 years ago
| 1 | 1 | {-# LANGUAGE RankNTypes #-} |
| 2 | 2 | {-# LANGUAGE LambdaCase #-} |
| 3 | {-# LANGUAGE DeriveFunctor #-} | |
| 3 | 4 | |
| 4 | module Codec.ActivityStream.LensInternal where | |
| 5 | -- Okay, I'm gonna justify this in a comment: I will never, under any | |
| 6 | -- circumstances, build a library that has an explicit `lens` dependency. | |
| 7 | -- I think `lens` is awesome, but it is also a giant package, and I | |
| 8 | -- don't want to inflict it on end-users who might not want it. | |
| 9 | ||
| 10 | -- I am more okay with lens-family-core, but in this case, all I need | |
| 11 | -- is really the `makeLens` function, which (not counting whitespace | |
| 12 | -- and comments) is three lines of code. Three lines! And it doesn't make | |
| 13 | -- sense to drag in a whole extra package when I can just copy this | |
| 14 | -- in. | |
| 15 | ||
| 16 | -- There's also reimplementations of `get` and `set` for possible internal | |
| 17 | -- use---three lines each, for a total of nine. Nine lines of | |
| 18 | -- easily-copyable, verifiable boilerplate. Instead of another dependency | |
| 19 | -- that must be downloaded and installed and managed by Cabal and | |
| 20 | -- addressed in constraint-solving... | |
| 21 | ||
| 22 | -- And that is why this module reimplement a few `lens` functions. | |
| 23 | ||
| 24 | module Codec.ActivityStream.LensInternal | |
| 25 | ( get | |
| 26 | , set | |
| 27 | , Lens' | |
| 28 | , makeLens | |
| 29 | , makeAesonLensMb | |
| 30 | , makeAesonLens | |
| 31 | ) where | |
| 5 | 32 | |
| 6 | 33 | import Data.Aeson as Aeson |
| 7 | 34 | import qualified Data.HashMap.Strict as HM |
| 8 | 35 | import Data.Maybe (fromJust) |
| 9 | 36 | import Data.Text (Text) |
| 10 | 37 | |
| 11 | -- This way, we don't have to import lens... but we can still export lenses! | |
| 12 | newtype Const a b = Const { fromConst :: a } | |
| 13 | instance Functor (Const a) where fmap f (Const x) = Const x | |
| 38 | -- We need these to write get and set | |
| 39 | newtype C a b = C { fromC :: a } deriving (Functor) | |
| 40 | newtype I a = I { fromI :: a } deriving (Functor) | |
| 14 | 41 | |
| 15 | -- We need these to write get and set | |
| 16 | newtype Id a = Id { fromId :: a } | |
| 17 | instance Functor Id where fmap f (Id x) = Id (f x) | |
| 18 | ||
| 19 | -- | This is the same type alias as in @Control.Lens@, and so can be used | |
| 20 | -- anywhere lenses are needed. | |
| 42 | -- This is the same type alias as in @Control.Lens@, and so can be used | |
| 43 | -- anywhere lenses are needed. | |
| 21 | 44 | type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a) |
| 22 | 45 | |
| 23 | 46 | get :: Lens' a b -> a -> b |
| 24 |
get lens a = fromC |
|
| 47 | get lens a = fromC (lens C a) | |
| 25 | 48 | |
| 26 | 49 | set :: Lens' a b -> b -> a -> a |
| 27 |
set lens x a = fromI |
|
| 50 | set lens x a = fromI (lens (const I x) a) | |
| 28 | 51 | |
| 29 | 52 | makeLens :: (a -> b) -> (b -> a -> a) -> Lens' a b |
| 30 | 53 | makeLens get set f a = (`set` a) `fmap` f (get a) |
| 31 | 54 | |
| 55 | -- This is necessary because of the way we store values as Aeson | |
| 56 | -- values underneath. | |
| 32 | 57 | fromJSON' :: FromJSON a => Aeson.Value -> Maybe a |
| 33 | 58 | fromJSON' v = case fromJSON v of |
| 34 | 59 | Success a -> Just a |
| 35 | 60 | Error _ -> Nothing |
| 36 | 61 | |
| 37 | 62 | -- Create a lens into an Aeson object wrapper that takes and |
| 38 |
-- returns a Maybe value |
|
| 63 | -- returns a Maybe value. When used as a setter, it can either | |
| 64 | -- insert a value in, or delete it from the object (if it is | |
| 65 | -- used with Nothing.) | |
| 39 | 66 | makeAesonLensMb :: (FromJSON v, ToJSON v) |
| 40 | 67 | => Text -> Lens' c Aeson.Object -> Lens' c (Maybe v) |
| 41 | makeAesonLensMb key fromObj = fromObj . lens | |
| 42 | where lens = makeLens | |
| 43 | (\ o -> HM.lookup key o >>= fromJSON') | |
| 44 | (\case Just v -> HM.insert key (toJSON v) | |
| 45 | Nothing -> HM.delete key) | |
| 68 | makeAesonLensMb key fromObj = fromObj . makeLens g s | |
| 69 | where g o = HM.lookup key o >>= fromJSON' | |
| 70 | s (Just v) o = HM.insert key (toJSON v) o | |
| 71 | s Nothing o = HM.delete key o | |
| 46 | 72 | |
| 47 | 73 | |
| 48 |
-- Create a lens into an Aeson object wrapper |
|
| 74 | -- Create a lens into an Aeson object wrapper. This will fail if | |
| 75 | -- the object does not contain the relevant key. | |
| 49 | 76 | makeAesonLens :: (FromJSON v, ToJSON v) |
| 50 | 77 | => Text -> Lens' c Aeson.Object -> Lens' c v |
| 51 | makeAesonLens key fromObj = fromObj . lens | |
| 52 | where lens = makeLens | |
| 53 | (\ o -> fromJust (HM.lookup key o >>= fromJSON')) | |
| 54 | (\ v o -> HM.insert key (toJSON v) o) | |
| 78 | makeAesonLens key fromObj = fromObj . makeLens g s | |
| 79 | where g o = fromJust (HM.lookup key o >>= fromJSON') | |
| 80 | s v o = HM.insert key (toJSON v) o |