{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif

#include "lens-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.TH
-- Copyright   :  (C) 2012-16 Edward Kmett, 2012-13 Michael Sloan
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Control.Lens.TH
  (
  -- * Constructing Lenses Automatically
  -- ** Lenses for data fields
    makeLenses, makeLensesFor
  , makeClassy, makeClassyFor, makeClassy_
  , makeFields
  , makeFieldsNoPrefix
  -- ** Prisms
  , makePrisms
  , makeClassyPrisms
  -- ** Wrapped
  , makeWrapped
  -- * Constructing Lenses Given a Declaration Quote
  -- ** Lenses for data fields
  , declareLenses, declareLensesFor
  , declareClassy, declareClassyFor
  , declareFields
  -- ** Prisms
  , declarePrisms
  -- ** Wrapped
  , declareWrapped
  -- * Configuring Lenses
  -- ** Running LensRules
  , makeLensesWith
  , declareLensesWith
  -- ** LensRules type
  , LensRules
  -- ** Predefined LensRules
  , lensRules
  , lensRulesFor
  , classyRules
  , classyRules_
  , defaultFieldRules
  , camelCaseFields
  , classUnderscoreNoPrefixFields
  , underscoreFields
  , abbreviatedFields
  -- ** LensRules configuration accessors
  , lensField
  , FieldNamer
  , DefName(..)
  , lensClass
  , ClassyNamer
  , simpleLenses
  , createClass
  , generateSignatures
  , generateUpdateableOptics
  , generateLazyPatterns
  , generateRecordSyntax
  -- ** FieldNamers
  , underscoreNoPrefixNamer
  , lookingupNamer
  , mappingNamer
  , camelCaseNamer
  , classUnderscoreNoPrefixNamer
  , underscoreNamer
  , abbreviatedNamer
  ) where

import Prelude ()

import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Lens.Traversal
import Control.Lens.Internal.Prelude as Prelude
import Control.Lens.Internal.TH
import Control.Lens.Internal.FieldTH
import Control.Lens.Internal.PrismTH
import Control.Lens.Wrapped () -- haddocks
import Control.Lens.Type () -- haddocks
import Data.Char (toLower, toUpper, isUpper)
import Data.Foldable hiding (concat, any)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (maybeToList)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Traversable hiding (mapM)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lens
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax hiding (lift)

-- | Generate "simple" optics even when type-changing optics are possible.
-- (e.g. 'Lens'' instead of 'Lens')
simpleLenses :: Lens' LensRules Bool
simpleLenses :: Lens' LensRules Bool
simpleLenses Bool -> f Bool
f LensRules
r = (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _simpleLenses = x}) (Bool -> f Bool
f (LensRules -> Bool
_simpleLenses LensRules
r))

-- | Indicate whether or not to supply the signatures for the generated
-- lenses.
--
-- Disabling this can be useful if you want to provide a more restricted type
-- signature or if you want to supply hand-written haddocks.
generateSignatures :: Lens' LensRules Bool
generateSignatures :: Lens' LensRules Bool
generateSignatures Bool -> f Bool
f LensRules
r =
  (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateSigs = x}) (Bool -> f Bool
f (LensRules -> Bool
_generateSigs LensRules
r))

-- | Generate "updateable" optics when 'True'. When 'False', 'Fold's will be
-- generated instead of 'Traversal's and 'Getter's will be generated instead
-- of 'Lens'es. This mode is intended to be used for types with invariants
-- which must be maintained by "smart" constructors.
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics Bool -> f Bool
f LensRules
r =
  (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _allowUpdates = x}) (Bool -> f Bool
f (LensRules -> Bool
_allowUpdates LensRules
r))

-- | Generate optics using lazy pattern matches. This can
-- allow fields of an undefined value to be initialized with lenses:
--
-- @
-- data Foo = Foo {_x :: Int, _y :: Bool}
--   deriving Show
--
-- 'makeLensesWith' ('lensRules' & 'generateLazyPatterns' .~ True) ''Foo
-- @
--
-- @
-- > undefined & x .~ 8 & y .~ True
-- Foo {_x = 8, _y = True}
-- @
--
-- The downside of this flag is that it can lead to space-leaks and
-- code-size/compile-time increases when generated for large records. By
-- default this flag is turned off, and strict optics are generated.
--
-- When using lazy optics the strict optic can be recovered by composing
-- with '$!':
--
-- @
-- strictOptic = ($!) . lazyOptic
-- @
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns Bool -> f Bool
f LensRules
r =
  (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _lazyPatterns = x}) (Bool -> f Bool
f (LensRules -> Bool
_lazyPatterns LensRules
r))

generateRecordSyntax :: Lens' LensRules Bool
generateRecordSyntax :: Lens' LensRules Bool
generateRecordSyntax Bool -> f Bool
f LensRules
r =
  (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r {_recordSyntax = x}) (Bool -> f Bool
f (LensRules -> Bool
_recordSyntax LensRules
r))

-- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the
-- 'lensClass' rule matches.
createClass :: Lens' LensRules Bool
createClass :: Lens' LensRules Bool
createClass Bool -> f Bool
f LensRules
r =
  (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateClasses = x}) (Bool -> f Bool
f (LensRules -> Bool
_generateClasses LensRules
r))

-- | 'Lens'' to access the convention for naming fields in our 'LensRules'.
lensField :: Lens' LensRules FieldNamer
lensField :: Lens' LensRules FieldNamer
lensField FieldNamer -> f FieldNamer
f LensRules
r = (FieldNamer -> LensRules) -> f FieldNamer -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNamer
x -> LensRules
r { _fieldToDef = x}) (FieldNamer -> f FieldNamer
f (LensRules -> FieldNamer
_fieldToDef LensRules
r))

-- | 'Lens'' to access the option for naming "classy" lenses.
lensClass :: Lens' LensRules ClassyNamer
lensClass :: Lens' LensRules ClassyNamer
lensClass ClassyNamer -> f ClassyNamer
f LensRules
r = (ClassyNamer -> LensRules) -> f ClassyNamer -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ClassyNamer
x -> LensRules
r { _classyLenses = x }) (ClassyNamer -> f ClassyNamer
f (LensRules -> ClassyNamer
_classyLenses LensRules
r))

-- | Rules for making fairly simple partial lenses, ignoring the special cases
-- for isomorphisms and traversals, and not making any classes.
-- It uses 'underscoreNoPrefixNamer'.
lensRules :: LensRules
lensRules :: LensRules
lensRules = LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
False
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
False
  , _allowIsos :: Bool
_allowIsos       = Bool
True
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _recordSyntax :: Bool
_recordSyntax    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
underscoreNoPrefixNamer
  }

-- | A 'FieldNamer' that strips the _ off of the field name,
-- lowercases the name, and skips the field if it doesn't start with
-- an '_'.
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer Name
_ [Name]
_ Name
n =
  case Name -> String
nameBase Name
n of
    Char
'_':Char
x:String
xs -> [Name -> DefName
TopName (String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))]
    String
_        -> []


-- | Construct a 'LensRules' value for generating top-level definitions
-- using the given map from field names to definition names.
lensRulesFor ::
  [(String, String)] {- ^ [(Field Name, Definition Name)] -} ->
  LensRules
lensRulesFor :: [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields = LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields

-- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer :: [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
kvs Name
_ [Name]
_ Name
field =
  [ Name -> DefName
TopName (String -> Name
mkName String
v) | (String
k,String
v) <- [(String, String)]
kvs, String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
field]

-- | Create a 'FieldNamer' from a mapping function. If the function
-- returns @[]@, it creates no lens for the field.
mappingNamer :: (String -> [String]) -- ^ A function that maps a @fieldName@ to @lensName@s.
             -> FieldNamer
mappingNamer :: (String -> [String]) -> FieldNamer
mappingNamer String -> [String]
mapper Name
_ [Name]
_ = (String -> DefName) -> [String] -> [DefName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DefName
TopName (Name -> DefName) -> (String -> Name) -> String -> DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [DefName]) -> (Name -> [String]) -> Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
mapper (String -> [String]) -> (Name -> String) -> Name -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Rules for making lenses and traversals that precompose another 'Lens'.
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
True
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
True
  , _allowIsos :: Bool
_allowIsos       = Bool
False -- generating Isos would hinder "subtyping"
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _recordSyntax :: Bool
_recordSyntax    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = \Name
n ->
        case Name -> String
nameBase Name
n of
          Char
x:String
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (String -> Name
mkName (String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs), String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))
          []   -> Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
underscoreNoPrefixNamer
  }

-- | Rules for making lenses and traversals that precompose another 'Lens'
-- using a custom function for naming the class, main class method, and a
-- mapping from field names to definition names.
classyRulesFor
  :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} ->
  [(String, String)] {- ^ [(Field Name, Method Name)] -} ->
  LensRules
classyRulesFor :: (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor String -> Maybe (String, String)
classFun [(String, String)]
fields = LensRules
classyRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (ClassyNamer -> Identity ClassyNamer)
-> LensRules -> Identity LensRules
Lens' LensRules ClassyNamer
lensClass ((ClassyNamer -> Identity ClassyNamer)
 -> LensRules -> Identity LensRules)
-> ClassyNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ASetter (Maybe (String, String)) (Maybe (Name, Name)) String Name
-> (String -> Name) -> Maybe (String, String) -> Maybe (Name, Name)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((String, String) -> Identity (Name, Name))
-> Maybe (String, String) -> Identity (Maybe (Name, Name))
Setter
  (Maybe (String, String))
  (Maybe (Name, Name))
  (String, String)
  (Name, Name)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((String, String) -> Identity (Name, Name))
 -> Maybe (String, String) -> Identity (Maybe (Name, Name)))
-> ((String -> Identity Name)
    -> (String, String) -> Identity (Name, Name))
-> ASetter
     (Maybe (String, String)) (Maybe (Name, Name)) String Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity Name)
-> (String, String) -> Identity (Name, Name)
Traversal (String, String) (Name, Name) String Name
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) String -> Name
mkName (Maybe (String, String) -> Maybe (Name, Name))
-> (Name -> Maybe (String, String)) -> ClassyNamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, String)
classFun (String -> Maybe (String, String))
-> (Name -> String) -> Name -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields

-- | A 'LensRules' used by 'makeClassy_'.
classyRules_ :: LensRules
classyRules_ :: LensRules
classyRules_
  = LensRules
classyRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName (String -> Name
mkName (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
n))]

-- | Build lenses (and traversals) with a sensible default configuration.
--
-- /e.g./
--
-- @
-- data FooBar
--   = Foo { _x, _y :: 'Int' }
--   | Bar { _x :: 'Int' }
-- 'makeLenses' ''FooBar
-- @
--
-- will create
--
-- @
-- x :: 'Lens'' FooBar 'Int'
-- x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a
-- x f (Bar a)   = Bar \<$\> f a
-- y :: 'Traversal'' FooBar 'Int'
-- y f (Foo a b) = (\\b\' -> Foo a  b\') \<$\> f b
-- y _ c\@(Bar _) = pure c
-- @
--
-- @
-- 'makeLenses' = 'makeLensesWith' 'lensRules'
-- @
makeLenses :: Name -> DecsQ
makeLenses :: Name -> DecsQ
makeLenses = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
lensRules

-- | Make lenses and traversals for a type, and create a class when the
-- type has no arguments.
--
-- /e.g./
--
-- @
-- data Foo = Foo { _fooX, _fooY :: 'Int' }
-- 'makeClassy' ''Foo
-- @
--
-- will create
--
-- @
-- class HasFoo t where
--   foo :: 'Lens'' t Foo
--   fooX :: 'Lens'' t 'Int'
--   fooX = foo . go where go f (Foo x y) = (\\x\' -> Foo x' y) \<$\> f x
--   fooY :: 'Lens'' t 'Int'
--   fooY = foo . go where go f (Foo x y) = (\\y\' -> Foo x y') \<$\> f y
-- instance HasFoo Foo where
--   foo = id
-- @
--
-- @
-- 'makeClassy' = 'makeLensesWith' 'classyRules'
-- @
makeClassy :: Name -> DecsQ
makeClassy :: Name -> DecsQ
makeClassy = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules

-- | Make lenses and traversals for a type, and create a class when the type
-- has no arguments.  Works the same as 'makeClassy' except that (a) it
-- expects that record field names do not begin with an underscore, (b) all
-- record fields are made into lenses, and (c) the resulting lens is prefixed
-- with an underscore.
makeClassy_ :: Name -> DecsQ
makeClassy_ :: Name -> DecsQ
makeClassy_ = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules_

-- | Derive lenses and traversals, specifying explicit pairings
-- of @(fieldName, lensName)@.
--
-- If you map multiple names to the same label, and it is present in the same
-- constructor then this will generate a 'Traversal'.
--
-- /e.g./
--
-- @
-- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
-- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
-- @
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics ([(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields)

-- | Derive lenses and traversals, using a named wrapper class, and
-- specifying explicit pairings of @(fieldName, traversalName)@.
--
-- Example usage:
--
-- @
-- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo
-- @
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor String
clsName String
funName [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$
  (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (Maybe (String, String) -> String -> Maybe (String, String)
forall a b. a -> b -> a
const ((String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
clsName, String
funName))) [(String, String)]
fields

-- | Build lenses with a custom configuration.
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = LensRules -> Name -> DecsQ
makeFieldOptics



-- | Make lenses for all records in the given declaration quote. All record
-- syntax in the input will be stripped off.
--
-- /e.g./
--
-- @
-- declareLenses [d|
--   data Foo = Foo { fooX, fooY :: 'Int' }
--     deriving 'Show'
--   |]
-- @
--
-- will create
--
-- @
-- data Foo = Foo 'Int' 'Int' deriving 'Show'
-- fooX, fooY :: 'Lens'' Foo Int
-- @
declareLenses :: DecsQ -> DecsQ
declareLenses :: DecsQ -> DecsQ
declareLenses
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
lensRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]

-- | Similar to 'makeLensesFor', but takes a declaration quote.
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor [(String, String)]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]

-- | For each record in the declaration quote, make lenses and traversals for
-- it, and create a class when the type has no arguments. All record syntax
-- in the input will be stripped off.
--
-- /e.g./
--
-- @
-- declareClassy [d|
--   data Foo = Foo { fooX, fooY :: 'Int' }
--     deriving 'Show'
--   |]
-- @
--
-- will create
--
-- @
-- data Foo = Foo 'Int' 'Int' deriving 'Show'
-- class HasFoo t where
--   foo :: 'Lens'' t Foo
-- instance HasFoo Foo where foo = 'id'
-- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'
-- @
declareClassy :: DecsQ -> DecsQ
declareClassy :: DecsQ -> DecsQ
declareClassy
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]

-- | Similar to 'makeClassyFor', but takes a declaration quote.
declareClassyFor ::
  [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor :: [(String, (String, String))]
-> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor [(String, (String, String))]
classes [(String, String)]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (String -> [(String, (String, String))] -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup`[(String, (String, String))]
classes) [(String, String)]
fields
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]

-- | Generate a 'Control.Lens.Type.Prism' for each constructor of each data type.
--
-- /e.g./
--
-- @
-- declarePrisms [d|
--   data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }
--   |]
-- @
--
-- will create
--
-- @
-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }
-- _Lit :: 'Prism'' Exp Int
-- _Var :: 'Prism'' Exp String
-- _Lambda :: 'Prism'' Exp (String, Exp)
-- @
declarePrisms :: DecsQ -> DecsQ
declarePrisms :: DecsQ -> DecsQ
declarePrisms = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  [Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DecsQ -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall a. Q a -> Declare a
liftDeclare (Bool -> Dec -> DecsQ
makeDecPrisms Bool
True Dec
dec)
  Dec -> Declare Dec
forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec

-- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype.
declareWrapped :: DecsQ -> DecsQ
declareWrapped :: DecsQ -> DecsQ
declareWrapped = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  Maybe [Dec]
maybeDecs <- Q (Maybe [Dec]) -> Declare (Maybe [Dec])
forall a. Q a -> Declare a
liftDeclare (Q (Maybe [Dec]) -> Declare (Maybe [Dec]))
-> Q (Maybe [Dec]) -> Declare (Maybe [Dec])
forall a b. (a -> b) -> a -> b
$ do
    DatatypeInfo
inf <- Dec -> Q DatatypeInfo
normalizeDec Dec
dec
    DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo DatatypeInfo
inf
  Maybe [Dec] -> ([Dec] -> Declare ()) -> Declare ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Dec]
maybeDecs [Dec] -> Declare ()
emit
  Dec -> Declare Dec
forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec

-- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @
declareFields :: DecsQ -> DecsQ
declareFields :: DecsQ -> DecsQ
declareFields = LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
defaultFieldRules

-- | Declare lenses for each records in the given declarations, using the
-- specified 'LensRules'. Any record syntax in the input will be stripped
-- off.
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
rules = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  [Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Set Name) Q [Dec]
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules Dec
dec)
  Dec -> Declare Dec
forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Declare Dec) -> Dec -> Declare Dec
forall a b. (a -> b) -> a -> b
$ Dec -> Dec
stripFields Dec
dec

-----------------------------------------------------------------------------
-- Internal TH Implementation
-----------------------------------------------------------------------------

-- | Given a set of names, build a map from those names to a set of fresh names
-- based on them.
freshMap :: Set Name -> Q (Map Name Name)
freshMap :: Set Name -> Q (Map Name Name)
freshMap Set Name
ns = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> Q [(Name, Name)] -> Q (Map Name Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name] -> (Name -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Set Name -> [Name]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Name
ns) (\ Name
n -> (,) Name
n (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n))


apps :: Type -> [Type] -> Type
apps :: Type -> [Type] -> Type
apps = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Type -> Type -> Type
AppT


-- | Build 'Wrapped' instance for a given newtype
makeWrapped :: Name -> DecsQ
makeWrapped :: Name -> DecsQ
makeWrapped Name
nm = do
  DatatypeInfo
inf <- Name -> Q DatatypeInfo
reifyDatatype Name
nm
  Maybe [Dec]
maybeDecs <- DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo DatatypeInfo
inf
  DecsQ -> ([Dec] -> DecsQ) -> Maybe [Dec] -> DecsQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> DecsQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeWrapped: Unsupported data type") [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
maybeDecs

makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo dataInfo :: DatatypeInfo
dataInfo@(DatatypeInfo{datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons})
  | [conInfo :: ConstructorInfo
conInfo@(ConstructorInfo{constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields})] <- [ConstructorInfo]
cons
  , [Type
field] <- [Type]
fields
  = do Dec
wrapped   <- DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance DatatypeInfo
dataInfo ConstructorInfo
conInfo Type
field
       Dec
rewrapped <- DatatypeInfo -> DecQ
makeRewrappedInstance DatatypeInfo
dataInfo
       Maybe [Dec] -> Q (Maybe [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Maybe [Dec]
forall a. a -> Maybe a
Just [Dec
rewrapped, Dec
wrapped])

  | Bool
otherwise = Maybe [Dec] -> Q (Maybe [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
forall a. Maybe a
Nothing

makeRewrappedInstance :: DatatypeInfo -> DecQ
makeRewrappedInstance :: DatatypeInfo -> DecQ
makeRewrappedInstance DatatypeInfo
dataInfo = do

   Q Type
t <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"

   let typeArgs :: [Name]
typeArgs = (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Name (TyVarBndr ()) Name -> TyVarBndr () -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name (TyVarBndr ()) Name
forall t. HasName t => Lens' t Name
Lens' (TyVarBndr ()) Name
name) (DatatypeInfo -> [TyVarBndr ()]
datatypeVars DatatypeInfo
dataInfo)

   [Name]
typeArgs' <- do
     Map Name Name
m <- Set Name -> Q (Map Name Name)
freshMap ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
typeArgs)
     [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Name] -> [Name]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
m [Name]
typeArgs)

       -- Con a b c...
   let appliedType :: Q Type
appliedType  = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs))

       -- Con a' b' c'...
       appliedType' :: Q Type
appliedType' = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs'))

       -- Con a' b' c'... ~ t
       eq :: Q Type
eq = Type -> Type -> Type
AppT(Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
appliedType' Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type
t

       -- Rewrapped (Con a b c...) t
       klass :: Q Type
klass = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
rewrappedTypeName Q Type -> [Q Type] -> Q Type
`appsT` [Q Type
appliedType, Q Type
t]

   -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t
   Q [Type] -> Q Type -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type
eq]) Q Type
klass []

makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance DatatypeInfo
dataInfo ConstructorInfo
conInfo Type
fieldType = do

  let conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo
  let typeArgs :: [Name]
typeArgs = Getting (Endo [Name]) [TyVarBndr ()] Name
-> [TyVarBndr ()] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Name]) [TyVarBndr ()] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [TyVarBndr ()] Name
typeVars (DatatypeInfo -> [TyVarBndr ()]
datatypeVars DatatypeInfo
dataInfo)

  -- Con a b c...
  let appliedType :: Type
appliedType  = DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs)

  -- type Unwrapped (Con a b c...) = $fieldType
  let unwrappedATF :: DecQ
unwrappedATF = Name -> Maybe [Q (TyVarBndr ())] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
unwrappedTypeName Maybe [Q (TyVarBndr ())]
forall a. Maybe a
Nothing
                       [Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
appliedType] (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
fieldType)

  -- Wrapped (Con a b c...)
  let klass :: Q Type
klass        = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
wrappedTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
appliedType

  -- _Wrapped' = iso (\(Con x) -> x) Con
  let wrapFun :: Q Exp
wrapFun      = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName
  let unwrapFun :: Q Exp
unwrapFun    = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x" Q Name -> (Name -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
  let body :: Q Exp
body         = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isoValName, Q Exp
unwrapFun, Q Exp
wrapFun]
  let isoMethod :: DecQ
isoMethod    = Name -> [Q Clause] -> DecQ
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
_wrapped'ValName [[Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]

  -- instance Wrapped (Con a b c...) where
  --   type Unwrapped (Con a b c...) = fieldType
  --   _Wrapped' = iso (\(Con x) -> x) Con
  Q [Type] -> Q Type -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Q Type
klass [DecQ
unwrappedATF, DecQ
isoMethod]

-- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's,
-- which are used to instantiate its 'datatypeVars'.
applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs di :: DatatypeInfo
di@(DatatypeInfo { datatypeName :: DatatypeInfo -> Name
datatypeName = Name
nm
                                     , datatypeVars :: DatatypeInfo -> [TyVarBndr ()]
datatypeVars = [TyVarBndr ()]
vars
                                     , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTypes
                                     }) [Type]
args =
  Type -> [Type] -> Type
apps (Name -> Type
ConT Name
nm) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$
  -- Drop kind signatures if possible to reduce the likelihood of needing to
  -- enable KindSignatures. The likelihood is already quite small, however.
  -- This function is only used for the benefit of {make,declare}Wrapped, and
  -- one needs to enable TypeFamilies in order for the generated code to
  -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind
  -- signatures is probably not required, but better to be safe then sorry.
  DatatypeInfo -> [Type] -> [Type]
dropSigsIfNonDataFam DatatypeInfo
di ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
  Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution ([(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr ()]
vars) [Type]
args)) [Type]
instTypes

overHead :: (a -> a) -> [a] -> [a]
overHead :: forall a. (a -> a) -> [a] -> [a]
overHead a -> a
_ []     = []
overHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

-- | Field rules for fields in the form @ _prefix_fieldname @
underscoreFields :: LensRules
underscoreFields :: LensRules
underscoreFields = LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
underscoreNamer

-- | A 'FieldNamer' for 'underscoreFields'.
underscoreNamer :: FieldNamer
underscoreNamer :: FieldNamer
underscoreNamer Name
_ [Name]
_ Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
  String
_      <- String -> Maybe String
prefix String
field'
  String
method <- Maybe String
niceLens
  String
cls    <- Maybe String
classNaming
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))
  where
    field' :: String
field' = Name -> String
nameBase Name
field
    prefix :: String -> Maybe String
prefix (Char
'_':String
xs) | Char
'_' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` String
xs = String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
xs)
    prefix String
_                             = Maybe String
forall a. Maybe a
Nothing
    niceLens :: Maybe String
niceLens    = String -> Maybe String
prefix String
field' Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
n -> Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) String
field'
    classNaming :: Maybe String
classNaming = Maybe String
niceLens Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"Has_" String -> String -> String
forall a. [a] -> [a] -> [a]
++)

-- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @
-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.
-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.
--
-- __Note__: The @prefix@ must be the same as the typename (with the first
-- letter lowercased). This is a change from lens versions before lens 4.5.
-- If you want the old behaviour, use 'makeLensesWith' 'abbreviatedFields'
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules

-- | A 'FieldNamer' for 'camelCaseFields'.
camelCaseNamer :: FieldNamer
camelCaseNamer :: FieldNamer
camelCaseNamer Name
tyName [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do

  String
fieldPart <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
expectedPrefix (Name -> String
nameBase Name
field)
  String
method    <- String -> Maybe String
computeMethod String
fieldPart
  let cls :: String
cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))

  where
  expectedPrefix :: String
expectedPrefix = String
optUnderscore String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overHead Char -> Char
toLower (Name -> String
nameBase Name
tyName)

  optUnderscore :: String
optUnderscore  = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]

  computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
  computeMethod String
_                  = Maybe String
forall a. Maybe a
Nothing

-- | Field rules for fields in the form @ _fieldname @ (the leading
-- underscore is mandatory).
--
-- __Note__: The primary difference to 'camelCaseFields' is that for
-- @classUnderscoreNoPrefixFields@ the field names are not expected to
-- be prefixed with the type name. This might be the desired behaviour
-- when the @DuplicateRecordFields@ extension is enabled.
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields =
  LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
classUnderscoreNoPrefixNamer

-- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer Name
_ [Name]
_ Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
  String
fieldUnprefixed <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
"_" (Name -> String
nameBase Name
field)
  let className :: String
className  = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overHead Char -> Char
toUpper String
fieldUnprefixed
      methodName :: String
methodName = String
fieldUnprefixed
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
className) (String -> Name
mkName String
methodName))

-- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @
-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.
-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.
--
-- Note that @prefix@ may be any string of characters that are not uppercase
-- letters. (In particular, it may be arbitrary string of lowercase letters
-- and numbers) This is the behavior that 'defaultFieldRules' had in lens
-- 4.4 and earlier.
abbreviatedFields :: LensRules
abbreviatedFields :: LensRules
abbreviatedFields = LensRules
defaultFieldRules { _fieldToDef = abbreviatedNamer }

-- | A 'FieldNamer' for 'abbreviatedFields'.
abbreviatedNamer :: FieldNamer
abbreviatedNamer :: FieldNamer
abbreviatedNamer Name
_ [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do

  String
fieldPart <- String -> Maybe String
stripMaxLc (Name -> String
nameBase Name
field)
  String
method    <- String -> Maybe String
computeMethod String
fieldPart
  let cls :: String
cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))

  where
  stripMaxLc :: String -> Maybe String
stripMaxLc String
f = do String
x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
optUnderscore String
f
                    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
x of
                      (String
p,String
s) | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
p Bool -> Bool -> Bool
|| String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
s -> Maybe String
forall a. Maybe a
Nothing
                            | Bool
otherwise                  -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
  optUnderscore :: String
optUnderscore  = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]

  computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
  computeMethod String
_                  = Maybe String
forall a. Maybe a
Nothing


-- | Generate overloaded field accessors.
--
-- /e.g/
--
-- @
-- data Foo a = Foo { _fooX :: 'Int', _fooY :: a }
-- newtype Bar = Bar { _barX :: 'Char' }
-- makeFields ''Foo
-- makeFields ''Bar
-- @
--
-- will create
--
-- @
-- _fooXLens :: Lens' (Foo a) Int
-- _fooYLens :: Lens (Foo a) (Foo b) a b
-- class HasX s a | s -> a where
--   x :: Lens' s a
-- instance HasX (Foo a) Int where
--   x = _fooXLens
-- class HasY s a | s -> a where
--   y :: Lens' s a
-- instance HasY (Foo a) a where
--   y = _fooYLens
-- _barXLens :: Iso' Bar Char
-- instance HasX Bar Char where
--   x = _barXLens
-- @
--
-- For details, see 'camelCaseFields'.
--
-- @
-- makeFields = 'makeLensesWith' 'defaultFieldRules'
-- @
makeFields :: Name -> DecsQ
makeFields :: Name -> DecsQ
makeFields = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
camelCaseFields

-- | Generate overloaded field accessors based on field names which
-- are only prefixed with an underscore (e.g. '_name'), not
-- additionally with the type name (e.g. '_fooName').
--
-- This might be the desired behaviour in case the
-- @DuplicateRecordFields@ language extension is used in order to get
-- rid of the necessity to prefix each field name with the type name.
--
-- As an example:
--
-- @
-- data Foo a  = Foo { _x :: 'Int', _y :: a }
-- newtype Bar = Bar { _x :: 'Char' }
-- makeFieldsNoPrefix ''Foo
-- makeFieldsNoPrefix ''Bar
-- @
--
-- will create classes
--
-- @
-- class HasX s a | s -> a where
--   x :: Lens' s a
-- class HasY s a | s -> a where
--   y :: Lens' s a
-- @
--
-- together with instances
--
-- @
-- instance HasX (Foo a) Int
-- instance HasY (Foo a) a where
-- instance HasX Bar Char where
-- @
--
-- For details, see 'classUnderscoreNoPrefixFields'.
--
-- @
-- makeFieldsNoPrefix = 'makeLensesWith' 'classUnderscoreNoPrefixFields'
-- @
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classUnderscoreNoPrefixFields

defaultFieldRules :: LensRules
defaultFieldRules :: LensRules
defaultFieldRules = LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
True
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
True  -- classes will still be skipped if they already exist
  , _allowIsos :: Bool
_allowIsos       = Bool
False -- generating Isos would hinder field class reuse
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _recordSyntax :: Bool
_recordSyntax    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
camelCaseNamer
  }


-- Declaration quote stuff

declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith Dec -> Declare Dec
fun = (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ)
-> ([Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec])
-> [Dec]
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Declare Dec)
-> [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> Declare Dec
fun ([Dec] -> DecsQ) -> DecsQ -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

-- | Monad for emitting top-level declarations as a side effect. We also track
-- the set of field class 'Name's that have been created and consult them to
-- avoid creating duplicate classes.

-- See #463 for more information.
type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)

liftDeclare :: Q a -> Declare a
liftDeclare :: forall a. Q a -> Declare a
liftDeclare = StateT (Set Name) Q a
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) Q a
 -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a)
-> (Q a -> StateT (Set Name) Q a)
-> Q a
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runDeclare :: Declare [Dec] -> DecsQ
runDeclare :: WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec = do
  ([Dec]
out, Endo [Dec]
endo) <- StateT (Set Name) Q ([Dec], Endo [Dec])
-> Set Name -> Q ([Dec], Endo [Dec])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
-> StateT (Set Name) Q ([Dec], Endo [Dec])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec) Set Name
forall a. Set a
Set.empty
  [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [Dec]
out [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Endo [Dec] -> [Dec] -> [Dec]
forall a. Endo a -> a -> a
appEndo Endo [Dec]
endo []

emit :: [Dec] -> Declare ()
emit :: [Dec] -> Declare ()
emit [Dec]
decs = Endo [Dec] -> Declare ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Endo [Dec] -> Declare ()) -> Endo [Dec] -> Declare ()
forall a b. (a -> b) -> a -> b
$ ([Dec] -> [Dec]) -> Endo [Dec]
forall a. (a -> a) -> Endo a
Endo ([Dec]
decs[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++)

-- | Traverse each data, newtype, data instance or newtype instance
-- declaration.
traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype :: forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> f Dec
f = (Dec -> f Dec) -> [Dec] -> f [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Dec -> f Dec
go
  where
    go :: Dec -> f Dec
go Dec
dec = case Dec
dec of
      DataD{} -> Dec -> f Dec
f Dec
dec
      NewtypeD{} -> Dec -> f Dec
f Dec
dec
      DataInstD{} -> Dec -> f Dec
f Dec
dec
      NewtypeInstD{} -> Dec -> f Dec
f Dec
dec

      -- Recurse into instance declarations because they main contain
      -- associated data family instances.
      InstanceD Maybe Overlap
moverlap [Type]
ctx Type
inst [Dec]
body -> Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
moverlap [Type]
ctx Type
inst ([Dec] -> Dec) -> f [Dec] -> f Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> f Dec) -> [Dec] -> f [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Dec -> f Dec
go [Dec]
body
      Dec
_ -> Dec -> f Dec
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec

stripFields :: Dec -> Dec
stripFields :: Dec -> Dec
stripFields Dec
dec = case Dec
dec of
  DataD [Type]
ctx Name
tyName [TyVarBndr BndrVis]
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
    [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [Type]
ctx Name
tyName [TyVarBndr BndrVis]
tyArgs Maybe Type
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
  NewtypeD [Type]
ctx Name
tyName [TyVarBndr BndrVis]
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
    [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [Type]
ctx Name
tyName [TyVarBndr BndrVis]
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
  DataInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
    [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
  NewtypeInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
    [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
  Dec
_ -> Dec
dec

deRecord :: Con -> Con
deRecord :: Con -> Con
deRecord con :: Con
con@NormalC{} = Con
con
deRecord con :: Con
con@InfixC{} = Con
con
deRecord (ForallC [TyVarBndr Specificity]
tyVars [Type]
ctx Con
con) = [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC [TyVarBndr Specificity]
tyVars [Type]
ctx (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Con -> Con
deRecord Con
con
deRecord (RecC Name
conName [VarBangType]
fields) = Name -> [BangType] -> Con
NormalC Name
conName ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields)
deRecord con :: Con
con@GadtC{} = Con
con
deRecord (RecGadtC [Name]
ns [VarBangType]
fields Type
retTy) = [Name] -> [BangType] -> Type -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields) Type
retTy

dropFieldName :: VarBangType -> BangType
dropFieldName :: VarBangType -> BangType
dropFieldName (Name
_, Bang
str, Type
typ) = (Bang
str, Type
typ)