generics-sop-lens.hs

   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
  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 --
  27 data Foobar = Foobar
  28     { fooBar   :: Int
  29     , fooXyzzy :: [FilePath]
  30     , fooQuux  :: Bool
  31     }
  32   deriving (GHC.Generic)
  33
  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             , ""
  51             ]
  52
  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
  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
  94 replaceTypes :: [String] -> [String]
  95 replaceTypes = map
  96     $ replace "[Char]" "String"
  97
  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'