-- | Use @-XRecordWildCards@ safely.
module SafeWildCards (fields, fieldsPrefixed, fieldsNamed) where

import Language.Haskell.TH (Name, PatQ, mkName, conP, varP, nameBase, recover)
import Language.Haskell.TH.Datatype

-- | Put all fields of a record constructor into scope.
--
-- @f $(fields 'Rec) = ...@ is equivalent to @f Rec{..}@, but the compiler
-- will warn you about all unused fields. Thus 'fields' brings compile-time
-- safety whenever you want to guarantee that a certain function uses all
-- fields of @Rec@.
--
-- To explicitly ignore a field, match it against @_@:
--
-- @
-- f $(fields 'Rec) = ...
--   where
--     -- Ignored fields
--     _ = (recUselessField1, recUselessField2)
-- @
--
-- Usage examples include @ToJSON@ instances and various encoders in
-- general:
--
-- @
-- instance ToJSON Rec where
--   toJSON $(fields 'Rec) = ...
-- @
--
-- __Note:__ if you want to define the data type and use 'fields' in the
-- same module, you will need to add @\$(pure [])@ after the type
-- declaration. See the post about <https://blog.monadfix.com/th-groups declaration groups>
-- for more details. Your code will look like this:
--
-- @
-- data Rec = ...
-- \$(pure [])
--
-- f $(fields 'Rec) = ...
-- @
fields :: Name -> PatQ
fields :: Name -> PatQ
fields = (String -> String) -> Name -> PatQ
fieldsNamed String -> String
forall a. a -> a
id

-- | Like 'fields', but prefixes all fields with the given prefix.
--
-- Useful if you need to put fields from more than one record into scope:
--
-- @
-- diff :: Rec -> Rec -> Text
-- diff $(fieldsPrefixed "a_" 'Rec) $(fieldsPrefixed "b_" 'Rec) = ...
-- @
fieldsPrefixed :: String -> Name -> PatQ
fieldsPrefixed :: String -> Name -> PatQ
fieldsPrefixed String
prefix = (String -> String) -> Name -> PatQ
fieldsNamed (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++)

-- | General form of 'fields' and 'fieldsPrefixed'.
fieldsNamed :: (String -> String) -> Name -> PatQ
fieldsNamed :: (String -> String) -> Name -> PatQ
fieldsNamed String -> String
f Name
recordConstructor = do
  ConstructorInfo
cons <-
    Q ConstructorInfo -> Q ConstructorInfo -> Q ConstructorInfo
forall a. Q a -> Q a -> Q a
recover
      (String -> Q ConstructorInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ConstructorInfo) -> String -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$
         String
"Could not find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
recordConstructor String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". If it is defined in the same module where you are using\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"      'safe-wild-cards', you need to break the declaration group like this:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"          data ... = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
recordConstructor String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ...\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"          $(pure [])\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"      Read the 'SafeWildCards' module documentation for more details.\n"
      )
      (Name -> Q ConstructorInfo
reifyConstructor Name
recordConstructor)
  case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
cons of
    RecordConstructor [Name]
recordFields ->
      Name -> [PatQ] -> PatQ
conP Name
recordConstructor ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> PatQ
varP (Name -> PatQ) -> (Name -> Name) -> Name -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
recordFields)
    ConstructorVariant
_ -> String -> PatQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PatQ) -> String -> PatQ
forall a b. (a -> b) -> a -> b
$
      String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
recordConstructor String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be a record constructor"