-
Notifications
You must be signed in to change notification settings - Fork 0
/
PolyLensTH.hs
54 lines (47 loc) · 1.76 KB
/
PolyLensTH.hs
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
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
module Data.PolyLensTH (
mkPolyLenses
, mkPolyLensesBy
, derivePolyLens
) where
import Language.Haskell.TH
mkPolyLenses :: Name -> Q [Dec]
mkPolyLenses = mkPolyLensesBy (drop 1)
mkPolyLensesBy :: (String -> String) -> Name -> Q [Dec]
mkPolyLensesBy nameTransform datatype = do
i <- reify datatype
let constructorFields = case i of
TyConI (DataD _ _ _ [RecC _ fs] _) -> fs
TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs
TyConI TySynD{} ->
error $ "Can't derive PolyLens for type synonym: " ++ datatypeStr
TyConI DataD{} ->
error $ "Can't derive PolyLens for tagged union: " ++ datatypeStr
_ ->
error $ "Not sure how to derive a PolyLens for: " ++ datatypeStr
concat `fmap` mapM (derivePolyLens nameTransform . fst') constructorFields
where
fst' (x, _, _) = x
datatypeStr = nameBase datatype
derivePolyLens :: (String -> String) -> Name -> Q [Dec]
derivePolyLens nameTransform field = do
body <- derivePolyLensBody nameTransform field
-- todo
-- sig <- derivePolyLensSig field
-- return [sig, body]
return [body]
-- given a record field name,
-- produces a single function declaration:
-- lensName f a = (\x -> a { field = x }) <$> f (field a)
derivePolyLensBody :: (String -> String) -> Name -> Q Dec
derivePolyLensBody nameTransform field = funD lensName [defLine]
where
lensName = mkName (nameTransform (nameBase field))
a = mkName "a"
f = mkName "f"
defLine = clause pats (normalB body) []
pats = [varP f, varP a]
body = [| (\x -> $(record a field [|x|]))
`fmap` $(appE (varE f) (appE (varE field) (varE a)))
|]
record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]