From 76c486b6e7ac1c894ccb43e927f8f400a761367f Mon Sep 17 00:00:00 2001 From: Nurlan Alkuatov Date: Tue, 5 Jul 2022 15:22:40 +0600 Subject: [PATCH] fixup! [#15] Add lenses for config-related types --- core/nyan-interpolation-core.cabal | 3 +- core/package.yaml | 1 + .../Interpolation/Nyan/Core/Internal/Base.hs | 2 +- core/src/Text/Interpolation/Nyan/Lens.hs | 52 ------------------- core/src/Text/Interpolation/Nyan/Lens/TH.hs | 39 ++++++++++---- core/src/Text/Interpolation/Nyan/Lens/Type.hs | 17 ------ core/tests/Test/Lens.hs | 17 +----- 7 files changed, 33 insertions(+), 98 deletions(-) delete mode 100644 core/src/Text/Interpolation/Nyan/Lens.hs delete mode 100644 core/src/Text/Interpolation/Nyan/Lens/Type.hs diff --git a/core/nyan-interpolation-core.cabal b/core/nyan-interpolation-core.cabal index 833a1d9..4a57190 100644 --- a/core/nyan-interpolation-core.cabal +++ b/core/nyan-interpolation-core.cabal @@ -32,9 +32,7 @@ library Text.Interpolation.Nyan.Core.Internal.Processor Text.Interpolation.Nyan.Core.Internal.RMode Text.Interpolation.Nyan.Core.Internal.Splice - Text.Interpolation.Nyan.Lens Text.Interpolation.Nyan.Lens.TH - Text.Interpolation.Nyan.Lens.Type Text.Interpolation.Nyan.RModes.Buildable Text.Interpolation.Nyan.RModes.CommonExtra Text.Interpolation.Nyan.RModes.Show @@ -142,6 +140,7 @@ test-suite nyan-interpolation-core-tests , base <4.17 , fmt , megaparsec + , microlens , mtl , nyan-interpolation-core , tasty diff --git a/core/package.yaml b/core/package.yaml index d8ddd09..99f2d15 100644 --- a/core/package.yaml +++ b/core/package.yaml @@ -37,6 +37,7 @@ tests: <<: *test-common dependencies: - HUnit + - microlens - nyan-interpolation-core - tasty - tasty-hunit-compat diff --git a/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs b/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs index a84ee47..709f745 100644 --- a/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs +++ b/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs @@ -10,7 +10,7 @@ import Data.Monoid (Endo (..)) import Data.Text (Text) import Language.Haskell.TH (ExpQ) -import Text.Interpolation.Nyan.Lens (makeLenses) +import Text.Interpolation.Nyan.Lens.TH (makeLenses) {- $setup diff --git a/core/src/Text/Interpolation/Nyan/Lens.hs b/core/src/Text/Interpolation/Nyan/Lens.hs deleted file mode 100644 index f0c8b8a..0000000 --- a/core/src/Text/Interpolation/Nyan/Lens.hs +++ /dev/null @@ -1,52 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Serokell --- --- SPDX-License-Identifier: MPL-2.0 - -module Text.Interpolation.Nyan.Lens - ( module Text.Interpolation.Nyan.Lens.TH - , module Text.Interpolation.Nyan.Lens.Type - , (^.) - - , (%~) - , (%=) - - , (.~) - , (.=) - - , (?~) - , (?=) - - , (&~) - ) - where - -import Control.Monad.State (MonadState, State, execState, modify) -import Control.Applicative (Const(..)) -import Data.Functor.Identity (Identity(..)) - -import Text.Interpolation.Nyan.Lens.TH -import Text.Interpolation.Nyan.Lens.Type - -(^.) :: s -> Getting a s a -> a -s ^. l = getConst $ l Const s - -(%~) :: ASetter s t a b -> (a -> b) -> s -> t -l %~ f = runIdentity . l (Identity . f) - -(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () -l %= f = modify (l %~ f) - -(.~) :: ASetter s t a b -> b -> s -> t -l .~ b = runIdentity . l (const $ Identity b) - -(.=) :: MonadState s m => ASetter s s a b -> b -> m () -l .= b = modify (l .~ b) - -(?~) :: ASetter s t a (Maybe b) -> b -> s -> t -l ?~ b = l .~ (Just b) - -(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () -l ?= b = modify (l ?~ b) - -(&~) :: s -> State s a -> s -s &~ l = execState l s diff --git a/core/src/Text/Interpolation/Nyan/Lens/TH.hs b/core/src/Text/Interpolation/Nyan/Lens/TH.hs index b361a43..dc35ca2 100644 --- a/core/src/Text/Interpolation/Nyan/Lens/TH.hs +++ b/core/src/Text/Interpolation/Nyan/Lens/TH.hs @@ -7,7 +7,7 @@ module Text.Interpolation.Nyan.Lens.TH ) where -import Control.Monad ((<=<)) +import Control.Monad (forM) import Language.Haskell.TH -- | Information about the record field the lenses will operate on. @@ -15,7 +15,12 @@ type RecordFieldInfo = (Name, Strict, Type) -- | Given a record datatype, derives lenses for all of its fields. makeLenses :: Name -> Q [Dec] -makeLenses = mapM deriveLens <=< extractRecordFields +makeLenses datatype = do + fields <- extractRecordFields datatype + fmap concat $ forM fields \field -> do + sig <- deriveLensSignature datatype field + body <- deriveLensBody field + return [sig, body] extractRecordFields :: Name -> Q [RecordFieldInfo] extractRecordFields datatype = do @@ -25,29 +30,41 @@ extractRecordFields datatype = do TyConI (DataD _ _ _ _ [RecC _ fs] _) -> fs TyConI (NewtypeD _ _ _ _ (RecC _ fs) _) -> fs TyConI (DataD _ _ _ _ [_] _) -> - error $ "Can't derive lenses without record selectors: " ++ datatypeStr + fail $ "Can't derive lenses without record selectors: " ++ datatypeStr TyConI NewtypeD{} -> - error $ "Can't derive lenses without record selectors: " ++ datatypeStr + fail $ "Can't derive lenses without record selectors: " ++ datatypeStr TyConI TySynD{} -> - error $ "Can't derive lenses for type synonym: " ++ datatypeStr + fail $ "Can't derive lenses for type synonym: " ++ datatypeStr TyConI DataD{} -> - error $ "Can't derive lenses for a sum type: " ++ datatypeStr + fail $ "Can't derive lenses for a sum type: " ++ datatypeStr _ -> - error $ "Can't derive lenses for: " ++ datatypeStr + fail $ "Can't derive lenses for: " ++ datatypeStr ++ ", type name required." +mkLensName :: Name -> Name +mkLensName = mkName . (<> "L") . nameBase + +deriveLensSignature :: Name -> RecordFieldInfo -> Q Dec +deriveLensSignature datatype (fieldName, _, fieldType) = + sigD (mkLensName fieldName) + [t|forall f. Functor f => ($field -> f $field) + -> $record -> f $record + |] + where + field = return fieldType + record = conT datatype + -- | Given a record field name, -- produces a single function declaration: -- @lensName f a = (\x -> a { field = x }) `fmap` f (field a)@ -deriveLens :: RecordFieldInfo -> Q Dec -deriveLens (fieldName, _, _) = funD lensName [defLine] +deriveLensBody :: RecordFieldInfo -> Q Dec +deriveLensBody (fieldName, _, _) = funD (mkLensName fieldName) [defLine] where - lensName = mkName $ (nameBase fieldName) <> "L" a = mkName "a" f = mkName "f" defLine = clause pats (normalB body) [] pats = [varP f, varP a] body = [| (\x -> $(record a fieldName [|x|])) - `fmap` $(appE (varE f) (appE (varE fieldName) (varE a))) + `fmap` $(varE f `appE` (varE fieldName `appE` varE a)) |] record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)] diff --git a/core/src/Text/Interpolation/Nyan/Lens/Type.hs b/core/src/Text/Interpolation/Nyan/Lens/Type.hs deleted file mode 100644 index d5c28f9..0000000 --- a/core/src/Text/Interpolation/Nyan/Lens/Type.hs +++ /dev/null @@ -1,17 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Serokell --- --- SPDX-License-Identifier: MPL-2.0 - -module Text.Interpolation.Nyan.Lens.Type where - -import Control.Applicative (Const) -import Data.Functor.Identity (Identity) - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -type Lens' s a = Lens s s a a - -type ASetter s t a b = (a -> Identity b) -> s -> Identity t -type ASetter' s a = ASetter s s a a - -type Getting r s a = (a -> Const r a) -> s -> Const r s -type SimpleGetter s a = forall r. Getting r s a diff --git a/core/tests/Test/Lens.hs b/core/tests/Test/Lens.hs index c54286d..b282877 100644 --- a/core/tests/Test/Lens.hs +++ b/core/tests/Test/Lens.hs @@ -4,10 +4,11 @@ module Test.Lens where +import Lens.Micro import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Text.Interpolation.Nyan.Lens +import Text.Interpolation.Nyan.Lens.TH (makeLenses) data Pair = Pair { first :: Int, second :: String } deriving stock (Show, Eq) @@ -38,20 +39,6 @@ test_makeLenses = testGroup "Lenses produced by 'makeLenses' work as expected" single & (valueL ?~ "Some value") @?= Single (Just "Some value") ] - - , testGroup "Operators leveraging 'MonadState', 'State' work as expected" - [ testCase "(&~) and (.=) work" do - (pair &~ do firstL .= 102) - @?= Pair 102 "Hundred" - - , testCase "(&~) and (?=) work" do - (single &~ do valueL ?= "Some value") - @?= Single (Just "Some value") - - , testCase "(&~) and (%=) work" do - (single &~ do valueL %= (const $ Just "Some value")) - @?= Single (Just "Some value") - ] ] where a & f = f a