fixup! [#15] Add lenses for config-related types

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

core/package.yaml

@@ -37,6 +37,7 @@ tests:
     <<: *test-common
     dependencies:
       - HUnit
+      - microlens
       - nyan-interpolation-core
       - tasty
       - tasty-hunit-compat

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
 

core/src/Text/Interpolation/Nyan/Lens/TH.hs

@@ -7,15 +7,20 @@ 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.
 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)]

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