make LTS branch pre-releases
[cabal.git] / generics-sop-lens.hs
blob3c3b484b72045642937b686aad5c6cf43eccfa3b
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 import qualified GHC.Generics as GHC
7 import Data.Char (toLower)
8 import Data.List (stripPrefix)
9 import Data.Typeable
10 import Generics.SOP
11 import Generics.SOP.GGP
13 -- | An example of generic deriving of lens code.
15 -- >>> putStrLn $ genericLenses (Proxy :: Proxy Foobar)
16 -- fooBar :: Lens' Foobar Int
17 -- fooBar f s = fmap (\x -> s { T.fooBar = x }) (T.fooBar s)
18 -- {-# INLINE fooBar #-}
19 -- <BLANKLINE>
20 -- fooXyzzy :: Lens' Foobar [[Char]]
21 -- fooXyzzy f s = fmap (\x -> s { T.fooXyzzy = x }) (T.fooXyzzy s)
22 -- {-# INLINE fooXyzzy #-}
23 -- ...
25 -- /Note:/ 'FilePath' i.e @type@ aliases are lost.
27 data Foobar = Foobar
28 { fooBar :: Int
29 , fooXyzzy :: [FilePath]
30 , fooQuux :: Bool
32 deriving (GHC.Generic)
34 genericLenses
35 :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs)
36 => proxy a
37 -> String
38 genericLenses p = case gdatatypeInfo p of
39 Newtype _ _ _ -> "-- newtype deriving not implemented"
40 ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented"
41 ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix constructor deriving not implemented"
42 ADT _ dn (Record _ fis :* Nil) ->
43 unlines $ concatMap replaceTypes $ hcollapse $ hcmap (Proxy :: Proxy Typeable) derive fis
44 where
45 derive :: forall x. Typeable x => FieldInfo x -> K [String] x
46 derive (FieldInfo fi) = K
47 [ fi ++ " :: Lens' " ++ dn ++ " " ++ showsPrec 11 (typeRep (Proxy :: Proxy x)) []
48 , fi ++ " f s = fmap (\\x -> s { T." ++ fi ++ " = x }) (f (T." ++ fi ++ " s))"
49 , "{-# INLINE " ++ fi ++ " #-}"
50 , ""
53 genericClassyLenses
54 :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs)
55 => proxy a
56 -> String
57 genericClassyLenses p = case gdatatypeInfo p of
58 Newtype _ _ _ -> "-- newtype deriving not implemented"
59 ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented"
60 ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix constructor deriving not implemented"
61 ADT _ dn (Record _ fis :* Nil) ->
62 unlines $ concatMap replaceTypes $
63 [[ "class Has" ++ dn ++ " a where"
64 , " " ++ dn' ++ " :: Lens' a " ++ dn
65 , ""
66 ]] ++
67 hcollapse (hcmap (Proxy :: Proxy Typeable) deriveCls fis) ++
68 [[ ""
69 , "instance Has" ++ dn ++ " " ++ dn ++ " where"
70 , " " ++ dn' ++ " = id"
71 , " {-# INLINE " ++ dn' ++ " #-}"
72 ]] ++
73 hcollapse (hcmap (Proxy :: Proxy Typeable) deriveInst fis)
74 where
75 dn' = case dn of
76 [] -> []
77 c:cs -> toLower c : cs
79 deriveCls :: forall x. Typeable x => FieldInfo x -> K [String] x
80 deriveCls (FieldInfo fi) = K
81 [ " " ++ fi ++ " :: Lens' a " ++ showsPrec 11 (typeRep (Proxy :: Proxy x)) []
82 , " " ++ fi ++ " = " ++ dn' ++ " . " ++ fi
83 , " {-# INLINE " ++ fi ++ " #-}"
84 , ""
87 deriveInst :: forall x. Typeable x => FieldInfo x -> K [String] x
88 deriveInst (FieldInfo fi) = K
89 [ " " ++ fi ++ " f s = fmap (\\x -> s { T." ++ fi ++ " = x }) (f (T." ++ fi ++ " s))"
90 , " {-# INLINE " ++ fi ++ " #-}"
91 , ""
94 replaceTypes :: [String] -> [String]
95 replaceTypes = map
96 $ replace "[Char]" "String"
98 replace :: String -> String -> String -> String
99 replace needle replacement = go where
100 go [] = []
101 go xs@(x:xs')
102 | Just ys <- stripPrefix needle xs = replacement ++ go ys
103 | otherwise = x : go xs'