miso/src/Miso/Lens/TH.hs at master · dmjio/miso · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
-----------------------------------------------------------------------------
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Lens.TH
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <[email protected]>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Lens.TH
  ( -- ** TH
    makeLenses
  , makeClassy
    -- ** Re-exports
  , lens
  , compose
  , this
  , Lens
  ) where
-----------------------------------------------------------------------------
import Data.Char
import Data.Maybe
import Language.Haskell.TH
-----------------------------------------------------------------------------
import Miso.Util (compose)
import Miso.Lens (this, lens, Lens)
-----------------------------------------------------------------------------
-- | Automatically generates Haskell lenses via template-haskell.
--
makeLenses :: Name -> Q [Dec]
makeLenses name = do
  reify name >>= \case
    TyConI (NewtypeD _ _ _ _ con _) -> do
      case con of
        RecC _ fieldNames ->
          pure (processFieldNames fieldNames)
        _ -> pure []
    TyConI (DataD _ _ _ _ cons _) ->
      flip concatMapM cons $ \case
        RecC _ fieldNames -> do
          pure (processFieldNames fieldNames)
        _ -> pure []
    _ -> pure []
  where
    processFieldNames fieldNames = concat
      [ mkFields fName (ConT name) fieldType
      | (fieldName, _, fieldType) <- fieldNames
      , let fName = nameBase fieldName
      , listToMaybe fName == Just '_'
      ]
    mkFields fieldName conType fieldType =
     let -- dmj: drops '_' prefix
       lensName = mkName (drop 1 fieldName)
     in
       [ FunD lensName
         [ Clause [] (NormalB (mkLens fieldName)) []
         ]
       , SigD lensName (mkLensType conType fieldType)
       ]
    concatMapM f xs =
      concat <$> mapM f xs
    mkLensType conType =
      AppT (AppT (ConT (mkName "Lens")) conType)
    mkLens n =
      AppE (AppE (VarE (mkName "lens")) (VarE (mkName n)))
        $ LamE [ VarP recName, VarP fieldName ]
        $ RecUpdE (VarE recName) [ (mkName n, VarE fieldName) ]
      where
        recName = mkName "record"
        fieldName = mkName "field"
-----------------------------------------------------------------------------
-- | Automatically generates classy lenses via template-haskell.
makeClassy :: Name -> Q [Dec]
makeClassy name = do
  reify name >>= \case
    TyConI (NewtypeD _ _ _ _ con _) -> do
      case con of
        RecC _ fieldNames ->
          pure (processFieldNames fieldNames)
        _ -> pure []
    TyConI (DataD _ _ _ _ cons _) ->
      flip concatMapM cons $ \case
        RecC _ fieldNames -> do
          pure (processFieldNames fieldNames)
        _ -> pure []
    _ -> pure []
  where
    instanceName =
      AppT (ConT (mkName ("Has" <> baseName))) (ConT name)
    baseName = nameBase name
    baseNameLower
      | x : xs <- baseName = toLower x : xs
      | otherwise = []
    processFieldNames fieldNames =
        [ InstanceD Nothing [] instanceName
          [ ValD (VarP (mkName baseNameLower)) (NormalB (VarE (mkName "this"))) []
            -- instance HasFoo Foo where foo = this
          ]
        , ClassD [] (mkName $ "Has" <> nameBase name)
            [ PlainTV (mkName baseNameLower) BndrReq
            ] [] $ reverse $ concat
            [ mkFields fName (VarT (mkName baseNameLower)) fieldType
            | (fieldName, _, fieldType) <- fieldNames
            , let fName = nameBase fieldName
            , listToMaybe fName == Just '_'
            ] ++
            [ SigD
                (mkName baseNameLower)
                (AppT
                   (AppT
                      (ConT (mkName "Lens"))
                      (VarT (mkName baseNameLower)))
                      (ConT name))
            ]
        ]
    mkFields fieldName varType fieldType =
      let -- dmj: drops '_' prefix
        lensName = mkName (drop 1 fieldName)
      in
        [ FunD lensName
          [ Clause [] (NormalB (wrapMkLens fieldName)) []
          ]
          -- fooX = lens _fooX (\r x -> r { _fooX = x }) . foo
        , SigD lensName (mkLensType varType fieldType)
          -- fooY :: Lens foo Int
        ]
    concatMapM f xs =
      concat <$> mapM f xs
    mkLensType varType x =
      AppT (AppT (ConT (mkName "Lens")) varType) x
    wrapMkLens n =
      AppE (AppE (VarE (mkName "compose")) (mkLens n)) (VarE (mkName baseNameLower))
    mkLens n
      = AppE (AppE (VarE (mkName "lens")) (VarE (mkName n)))
      $ LamE [ VarP recName, VarP fieldName ]
      $ RecUpdE (VarE recName) [ (mkName n, VarE fieldName) ]
      where
        recName = mkName "record"
        fieldName = mkName "field"
-------------------------------------------------------------------------------