1{-# LANGUAGE DataKinds #-} 2{-# LANGUAGE DeriveGeneric #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE GADTs #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6import qualified GHC.Generics as GHC 7import Data.Char (toLower) 8import Data.List (stripPrefix) 9import Data.Typeable 10import Generics.SOP 11import Generics.SOP.GGP 12 13-- | An example of generic deriving of lens code. 14-- 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-- ... 24-- 25-- /Note:/ 'FilePath' i.e @type@ aliases are lost. 26-- 27data Foobar = Foobar 28 { fooBar :: Int 29 , fooXyzzy :: [FilePath] 30 , fooQuux :: Bool 31 } 32 deriving (GHC.Generic) 33 34genericLenses 35 :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs) 36 => proxy a 37 -> String 38genericLenses 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 , "" 51 ] 52 53genericClassyLenses 54 :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs) 55 => proxy a 56 -> String 57genericClassyLenses 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 78 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 , "" 85 ] 86 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 , "" 92 ] 93 94replaceTypes :: [String] -> [String] 95replaceTypes = map 96 $ replace "[Char]" "String" 97 98replace :: String -> String -> String -> String 99replace 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' 104