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