-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
--
-- | Generic deriving with unbalanced trees.

module Morley.Util.CustomGeneric
  ( -- * Custom Generic strategies
    GenericStrategy
  , withDepths
  , rightBalanced
  , leftBalanced
  , rightComb
  , leftComb
  , haskellBalanced
    -- ** Entries reordering
  , reorderingConstrs
  , reorderingFields
  , reorderingData
  , alphabetically
  , leaveUnnamedFields
  , forbidUnnamedFields
    -- * Depth usage helpers
  , cstr
  , fld
    -- * Instance derivation
  , customGeneric

    -- * Helpers
  , fromDepthsStrategy
  , fromDepthsStrategy'

    -- * Internals
  , reifyDataType
  , deriveFullType
  , customGeneric'
  , makeRightBalDepths
  , mangleGenericStrategyFields
  , mangleGenericStrategyConstructors
  ) where

import Prelude hiding (Type)

import Control.Lens (traversed)
import Fmt (pretty)
import GHC.Generics qualified as G
import Generics.Deriving.TH (makeRep0Inline)
import Language.Haskell.TH
import Morley.Util.Generic (mkGenericTree)
import Morley.Util.TH (lookupTypeNameOrFail)
import Unsafe qualified (fromIntegral)

{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-}

----------------------------------------------------------------------------
-- Simple type synonyms
----------------------------------------------------------------------------

-- | Simple tuple specifying the depth of a constuctor and a list of depths
-- for its fields.
--
-- This is used as a way to specify the tree topology of the Generic instance
-- to derive.
type CstrDepth = (Natural, [Natural])

-- | Simple tuple that defines the "shape" of a constructor: it's name and number
-- of fields. Used only in this module.
type CstrShape = (Name, Int)

-- | Simple tuple that carries basic info about a constructor: it's name,
-- number of its fields and their names. Used only in this module.
type CstrNames = (Name, Int, Maybe [Name])

-- | Type of a strategy to derive 'G.Generic' instances.
data GenericStrategy = GenericStrategy
  { GenericStrategy -> [CstrShape] -> Q [CstrDepth]
gsEvalDepths :: [CstrShape] -> Q [CstrDepth]
    -- ^ Given the 'CstrShape's for given datatype,
    -- return the 'CstrDepth's for it.
    -- This function should when possible make checks and 'fail', using the
    -- constructors' 'Name' provided by the 'CstrShape'.
  , GenericStrategy -> forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
    -- ^ Reorder constructors given their names.
  , GenericStrategy -> forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
    -- ^ Reorder fields given their names, the argument depends on whether
    -- fields are part of record (and thus named) or not (unnamed).
  }

-- | Defines how to reorder fields or constructors.
type EntriesReorder = forall a. [(Text, a)] -> Q [a]

-- | Defines how to reorder fields when their names are unknown.
type UnnamedEntriesReorder = forall a. [a] -> Q [a]

-- | Simple type synonym used (internally) between functions, basically extending
-- 'CstrDepth' with the 'Name's of the constructor and its fields.
-- For fields it carries both names in the original order and in the order specified
-- by the strategy (and the latter is paired with depths).
data NamedCstrDepths = NCD
  { NamedCstrDepths -> Natural
ncdCstrDepth :: Natural
    -- ^ Constructor's depth
  , NamedCstrDepths -> Name
ncdCstrName :: Name
    -- ^ Constructor's name
  , NamedCstrDepths -> [Name]
ncdOrigFieldNames :: [Name]
    -- ^ Names of constructor fields in the original order.
  , NamedCstrDepths -> [(Natural, Name)]
ncdFields :: [(Natural, Name)]
    -- ^ Names and depths of constructor fields after the reordering.
  }

-- | Reorders entries corresponding to constructors (@a@) and fields (@b@)
-- according to some rule.
type EntriesTransp = forall a b. [a] -> Q [([b] -> Q [b], a)]

----------------------------------------------------------------------------
-- Generic strategies
----------------------------------------------------------------------------

-- | In this strategy the desired depths of contructors (in the type tree) and
-- fields (in each constructor's tree) are provided manually and simply checked
-- against the number of actual constructors and fields.
withDepths :: [CstrDepth] -> GenericStrategy
withDepths :: [CstrDepth] -> GenericStrategy
withDepths [CstrDepth]
treeDepths = ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy (([CstrShape] -> Q [CstrDepth]) -> GenericStrategy)
-> ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
forall a b. (a -> b) -> a -> b
$ \[CstrShape]
cstrShape -> do
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CstrDepth] -> Int
forall t. Container t => t -> Int
length [CstrDepth]
treeDepths Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [CstrShape] -> Int
forall t. Container t => t -> Int
length [CstrShape]
cstrShape) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    String
"Number of contructors' depths does not match number of data contructors."
  [([Natural], CstrShape)]
-> (Element [([Natural], CstrShape)] -> Q ()) -> Q ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
t -> (Element t -> m b) -> m ()
forM_ ([[Natural]] -> [CstrShape] -> [([Natural], CstrShape)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((CstrDepth -> [Natural]) -> [CstrDepth] -> [[Natural]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map CstrDepth -> [Natural]
forall a b. (a, b) -> b
snd [CstrDepth]
treeDepths) [CstrShape]
cstrShape) ((Element [([Natural], CstrShape)] -> Q ()) -> Q ())
-> (Element [([Natural], CstrShape)] -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \([Natural]
fDepths, (Name
constrName, Int
fldNum)) ->
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Natural] -> Int
forall t. Container t => t -> Int
length [Natural]
fDepths Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
fldNum) (Q () -> Q ()) -> (String -> Q ()) -> String -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
    String
"Number of fields' depths does not match number of field for data " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"constructor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Name
constrName
  return [CstrDepth]
treeDepths

-- | Strategy to make right-balanced instances (both in constructors and fields).
--
-- This will try its best to produce a flat tree:
--
-- * the balances of all leaves differ no more than by 1;
-- * leaves at left will have equal or lesser depth than leaves at right.
rightBalanced :: GenericStrategy
rightBalanced :: GenericStrategy
rightBalanced = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy Int -> [Natural]
makeRightBalDepths

-- | Strategy to make left-balanced instances (both in constructors and fields).
--
-- This is the same as symmetrically mapped 'rightBalanced'.
leftBalanced :: GenericStrategy
leftBalanced :: GenericStrategy
leftBalanced = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy ([Natural] -> [Natural]
forall a. [a] -> [a]
reverse ([Natural] -> [Natural]) -> (Int -> [Natural]) -> Int -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Natural]
makeRightBalDepths)

-- | Strategy to make fully right-leaning instances (both in constructors and fields).
rightComb :: GenericStrategy
rightComb :: GenericStrategy
rightComb = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy ([Natural] -> [Natural]
forall a. [a] -> [a]
reverse ([Natural] -> [Natural]) -> (Int -> [Natural]) -> Int -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Natural]
makeLeftCombDepths)

-- | Strategy to make fully left-leaning instances (both in constructors and fields).
leftComb :: GenericStrategy
leftComb :: GenericStrategy
leftComb = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy Int -> [Natural]
makeLeftCombDepths

-- | Strategy to make Haskell's Generics-like instances
-- (both in constructors and fields).
--
-- This is similar to 'rightBalanced', except for the "flat" part:
--
-- * for each node, size of the left subtree is equal or less by one than
-- size of the right subtree.
--
-- This strategy matches A1.1.
--
-- @customGeneric \"T\" haskellBalanced@ is equivalent to mere
-- @deriving stock Generic T@.
haskellBalanced :: GenericStrategy
haskellBalanced :: GenericStrategy
haskellBalanced = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy Int -> [Natural]
makeHaskellDepths

-- Order modifiers
----------------------------------------------------------------------------

-- | Modify given strategy to reorder constructors.
--
-- The reordering will take place before depths are evaluated and structure
-- of generic representation is formed.
--
-- Example: @reorderingConstrs alphabetically rightBalanced@.
reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy
reorderingConstrs :: (forall a. [(Text, a)] -> Q [a])
-> GenericStrategy -> GenericStrategy
reorderingConstrs forall a. [(Text, a)] -> Q [a]
reorder GenericStrategy
gs = GenericStrategy
gs
  { gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn = forall a. [(Text, a)] -> Q [a]
reorder
  }

-- | Modify given strategy to reorder fields.
--
-- Same notes as for 'reorderingConstrs' apply here.
--
-- Example: @reorderingFields forbidUnnamedFields alphabetically rightBalanced@.
reorderingFields
  :: UnnamedEntriesReorder
  -> EntriesReorder
  -> GenericStrategy -> GenericStrategy
reorderingFields :: UnnamedEntriesReorder
-> (forall a. [(Text, a)] -> Q [a])
-> GenericStrategy
-> GenericStrategy
reorderingFields UnnamedEntriesReorder
reorderUnnamed forall a. [(Text, a)] -> Q [a]
reorder GenericStrategy
gs = GenericStrategy
gs
  { gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn = ([a] -> Q [a])
-> ([(Text, a)] -> Q [a]) -> Either [a] [(Text, a)] -> Q [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [a] -> Q [a]
UnnamedEntriesReorder
reorderUnnamed [(Text, a)] -> Q [a]
forall a. [(Text, a)] -> Q [a]
reorder
  }

-- | Modify given strategy to reorder constructors and fields.
--
-- Same notes as for 'reorderingConstrs' apply here.
--
-- Example: @reorderingData forbidUnnamedFields alphabetically rightBalanced@.
reorderingData
  :: UnnamedEntriesReorder
  -> EntriesReorder
  -> GenericStrategy -> GenericStrategy
reorderingData :: UnnamedEntriesReorder
-> (forall a. [(Text, a)] -> Q [a])
-> GenericStrategy
-> GenericStrategy
reorderingData UnnamedEntriesReorder
reorderUnnamed forall a. [(Text, a)] -> Q [a]
reorder =
  UnnamedEntriesReorder
-> (forall a. [(Text, a)] -> Q [a])
-> GenericStrategy
-> GenericStrategy
reorderingFields UnnamedEntriesReorder
reorderUnnamed forall a. [(Text, a)] -> Q [a]
reorder (GenericStrategy -> GenericStrategy)
-> (GenericStrategy -> GenericStrategy)
-> GenericStrategy
-> GenericStrategy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [(Text, a)] -> Q [a])
-> GenericStrategy -> GenericStrategy
reorderingConstrs forall a. [(Text, a)] -> Q [a]
reorder

-- | Sort entries by name alphabetically.
alphabetically :: EntriesReorder
alphabetically :: forall a. [(Text, a)] -> Q [a]
alphabetically = [a] -> Q [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Q [a]) -> ([(Text, a)] -> [a]) -> [(Text, a)] -> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, a) -> a
forall a b. (a, b) -> b
snd ([(Text, a)] -> [a])
-> ([(Text, a)] -> [(Text, a)]) -> [(Text, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> Text) -> [(Text, a)] -> [(Text, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Text, a) -> Text
forall a b. (a, b) -> a
fst

-- | Leave unnamed fields intact, without any reordering.
leaveUnnamedFields :: UnnamedEntriesReorder
leaveUnnamedFields :: UnnamedEntriesReorder
leaveUnnamedFields = [a] -> Q [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Fail in case records are unnamed and we cannot figure
-- out the necessary reordering.
forbidUnnamedFields :: UnnamedEntriesReorder
forbidUnnamedFields :: UnnamedEntriesReorder
forbidUnnamedFields [a]
fields =
  if [a] -> Int
forall t. Container t => t -> Int
length [a]
fields Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
  then [a] -> Q [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
fields
  else String -> Q [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Encountered unnamed fields, cannot apply reordering"

----------------------------------------------------------------------------
-- Generic strategies' builders
----------------------------------------------------------------------------

-- | Construct a strategy that only constructs Generic instance of given
-- form, without e.g. changing the order of entries.
simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy [CstrShape] -> Q [CstrDepth]
mkDepths = GenericStrategy :: ([CstrShape] -> Q [CstrDepth])
-> (forall a. [(Text, a)] -> Q [a])
-> (forall a. Either [a] [(Text, a)] -> Q [a])
-> GenericStrategy
GenericStrategy
  { gsEvalDepths :: [CstrShape] -> Q [CstrDepth]
gsEvalDepths = [CstrShape] -> Q [CstrDepth]
mkDepths
  , gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn = [a] -> Q [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Q [a]) -> ([(Text, a)] -> [a]) -> [(Text, a)] -> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, a) -> a
forall a b. (a, b) -> b
snd
  , gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn = [a] -> Q [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Q [a])
-> (Either [a] [(Text, a)] -> [a])
-> Either [a] [(Text, a)]
-> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a])
-> ([(Text, a)] -> [a]) -> Either [a] [(Text, a)] -> [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [a] -> [a]
forall a. a -> a
id (((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, a) -> a
forall a b. (a, b) -> b
snd)
  }

-- | Helper to make a strategy that created depths for constructor and fields
-- in the same way, just from their number.
--
-- The provided function @f@ must satisfy the following rules:
--
-- * @length (f n) ≡ n@
-- * @sum $ (\x -> 2 ^^ (-x)) \<$\> f n ≡ 1@ (unless @n = 0@)
fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy = ((Int -> [Natural]) -> (Int -> [Natural]) -> GenericStrategy)
-> (Int -> [Natural]) -> GenericStrategy
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Int -> [Natural]) -> (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy'

-- | Like 'fromDepthsStrategy', but allows specifying different strategies for
-- constructors and fields.
fromDepthsStrategy' :: (Int -> [Natural]) -> (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy' :: (Int -> [Natural]) -> (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy' Int -> [Natural]
dCtorStrategy Int -> [Natural]
dFieldStrategy =
  ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy (([CstrShape] -> Q [CstrDepth]) -> GenericStrategy)
-> ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
forall a b. (a -> b) -> a -> b
$ \[CstrShape]
cShapes -> [CstrDepth] -> Q [CstrDepth]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CstrDepth] -> Q [CstrDepth]) -> [CstrDepth] -> Q [CstrDepth]
forall a b. (a -> b) -> a -> b
$
    [Natural] -> [[Natural]] -> [CstrDepth]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Natural]
dCtorStrategy (Int -> [Natural]) -> Int -> [Natural]
forall a b. (a -> b) -> a -> b
$ [CstrShape] -> Int
forall t. Container t => t -> Int
length [CstrShape]
cShapes) ([[Natural]] -> [CstrDepth]) -> [[Natural]] -> [CstrDepth]
forall a b. (a -> b) -> a -> b
$ (CstrShape -> [Natural]) -> [CstrShape] -> [[Natural]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Int -> [Natural]
dFieldStrategy (Int -> [Natural]) -> (CstrShape -> Int) -> CstrShape -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Int CstrShape Int -> CstrShape -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int CstrShape Int
forall s t a b. Field2 s t a b => Lens s t a b
_2) [CstrShape]
cShapes

makeRightBalDepths :: Int -> [Natural]
makeRightBalDepths :: Int -> [Natural]
makeRightBalDepths Int
n = (Element [Int] -> [Natural] -> [Natural])
-> [Natural] -> [Int] -> [Natural]
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr (([Natural] -> [Natural]) -> Int -> [Natural] -> [Natural]
forall a b. a -> b -> a
const [Natural] -> [Natural]
addRightBalDepth) [] [Int
1..Int
n]
  where
    addRightBalDepth :: [Natural] -> [Natural]
    addRightBalDepth :: [Natural] -> [Natural]
addRightBalDepth = \case
      [] -> [Natural
0]
      [Natural
x] -> [Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1]
      (Natural
x : Natural
y : [Natural]
xs) | Natural
x Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
y -> Natural
x Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural] -> [Natural]
addRightBalDepth (Natural
x Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
xs)
      (Natural
_ : Natural
y : [Natural]
xs) -> Natural
y Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: Natural
y Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: Natural
y Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
xs

makeLeftCombDepths :: Int -> [Natural]
makeLeftCombDepths :: Int -> [Natural]
makeLeftCombDepths Int
0 = []
makeLeftCombDepths Int
n = (Int -> Natural) -> [Int] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @Int @Natural) ([Int] -> [Natural]) -> [Int] -> [Natural]
forall a b. (a -> b) -> a -> b
$ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2..Int
1]

makeHaskellDepths :: Int -> [Natural]
makeHaskellDepths :: Int -> [Natural]
makeHaskellDepths Int
n =
  case [[Natural]] -> Maybe (NonEmpty [Natural])
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Int -> [Natural] -> [[Natural]]
forall a. Int -> a -> [a]
replicate Int
n [Natural
0]) of
    Maybe (NonEmpty [Natural])
Nothing -> []
    Just NonEmpty [Natural]
leaves -> (Natural -> [Natural] -> [Natural] -> [Natural])
-> NonEmpty [Natural] -> [Natural]
forall a. (Natural -> a -> a -> a) -> NonEmpty a -> a
mkGenericTree (\Natural
_ [Natural]
l [Natural]
r -> (Natural -> Natural) -> [Natural] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Natural -> Natural
forall a. Enum a => a -> a
succ ([Natural]
l [Natural] -> [Natural] -> [Natural]
forall a. [a] -> [a] -> [a]
++ [Natural]
r)) NonEmpty [Natural]
leaves

----------------------------------------------------------------------------
-- Depth usage helpers
----------------------------------------------------------------------------

-- | Helper for making a constructor depth.
--
-- Note that this is only intended to be more readable than directly using a
-- tuple with 'withDepths' and for the ability to be used in places where
-- @RebindableSyntax@ overrides the number literal resolution.
cstr :: forall n. KnownNat n => [Natural] -> CstrDepth
cstr :: forall (n :: Nat). KnownNat n => [Natural] -> CstrDepth
cstr [Natural]
flds = (Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. Proxy t
Proxy @n), [Natural]
flds)

-- | Helper for making a field depth.
--
-- Note that this is only intended to be more readable than directly using a
-- tuple with 'withDepths' and for the ability to be used in places where
-- @RebindableSyntax@ overrides the number literal resolution.
fld :: forall n. KnownNat n => Natural
fld :: forall (n :: Nat). KnownNat n => Natural
fld = Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n -> Natural) -> Proxy n -> Natural
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Nat}. Proxy t
Proxy @n

----------------------------------------------------------------------------
-- Instance derivation
----------------------------------------------------------------------------

{-# ANN module ("HLint: ignore Use snd" :: Text) #-}

-- | Derives the 'G.Generic' instance for a type given its name and a
-- 'GenericStrategy' to use.
--
-- The strategy is used to calculate the depths of the data-type constructors
-- and each constructors' fields.
--
-- The depths are used to generate the tree of the 'G.Generic' representation,
-- allowing for a custom one, in contrast with the one derived automatically.
--
-- This only supports "plain" @data@ types (no GADTs, no @newtype@s, etc.) and
-- requires the depths to describe a fully and well-defined tree (see 'unbalancedFold').
--
-- For example, this is valid (and uses the 'withDepths' strategy with the 'cstr'
-- and 'fld' helpers) and results in a balanced instance, equivalent to the
-- auto-derived one:
--
-- @@@
-- data CustomType a
--   = CustomUp Integer Integer
--   | CustomMid {unMid :: Natural}
--   | CustomDown a
--   | CustomNone
--
-- $(customGeneric "CustomType" $ withDepths
--   [ cstr @2 [fld @1, fld @1]
--   , cstr @2 [fld @0]
--   , cstr @2 [fld @0]
--   , cstr @2 []
--   ])
-- @@@
--
-- and this is a valid, but fully left-leaning one:
--
-- @@@
-- $(customGeneric "CustomType" $ withDepths
--   [ cstr @3 [fld @1, fld @1]
--   , cstr @3 [fld @0]
--   , cstr @2 [fld @0]
--   , cstr @1 []
--   ])
-- @@@
--
-- and, just as a demonstration, this is the same fully left-leaning one, but
-- made using the simpler 'leftComb' strategy:
--
-- @@@
-- $(customGeneric "CustomType" leftComb)
-- @@@
--
-- Developers are welcome to provide their own derivation strategies,
-- and some useful strategies can be found outside of this module by
-- 'GenericStrategy' signature.
customGeneric :: String -> GenericStrategy -> Q [Dec]
customGeneric :: String -> GenericStrategy -> Q [Dec]
customGeneric String
typeStr GenericStrategy
genStrategy = do
  -- Implementor's note:
  --
  -- Instead of using a name literal (@customGeneric ''T@), we use a string (@customGeneric \"T\"@)
  -- and then 'lookupTypeName' for the following reasons:
  --
  -- 1. We can control the error message when 'lookupTypeName' doesn't find the type in scope (as opposed to @''T@)
  -- 2. Most importantly, this was made with Indigo in mind, where we try as much as
  --    possible to use a simple syntax (to appeal to a broader audience) and so to avoid
  --    using more obscure Haskell syntax (like @''T@).

  -- reify the data type
  (Name
typeName, [Type]
_, Maybe Type
mKind, [TyVarBndr ()]
vars, [Con]
constructors) <- String -> Q Name
lookupTypeNameOrFail String
typeStr Q Name
-> (Name -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con]))
-> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
reifyDataType
  -- obtain info about its constructor and desired tree
  Type
derivedType <- Name -> Maybe Type -> [TyVarBndr ()] -> TypeQ
forall flag. Name -> Maybe Type -> [TyVarBndr flag] -> TypeQ
deriveFullType Name
typeName Maybe Type
mKind [TyVarBndr ()]
vars
  Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' Maybe Type
forall a. Maybe a
Nothing Name
typeName Type
derivedType  [Con]
constructors GenericStrategy
genStrategy

-- | If a 'Type' type is given, this function will generate a new 'Generic' instance with it,
-- and generate the appropriate "to" and "from" methods.
--
-- Otherwise, it'll generate a new 'Type' instance as well.
customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' Maybe Type
maybeRepType Name
typeName Type
derivedType [Con]
constructors GenericStrategy
genStrategy = do
  [CstrNames]
cNames <- [Con] -> Q [CstrNames]
cstrNames [Con]
constructors
  let cReordering :: EntriesTransp
      cReordering :: EntriesTransp
cReordering = GenericStrategy -> [CstrNames] -> EntriesTransp
reorderCstrs GenericStrategy
genStrategy [CstrNames]
cNames
  let cShapes :: [CstrShape]
cShapes = [CstrNames]
cNames [CstrNames] -> (CstrNames -> CstrShape) -> [CstrShape]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
name, Int
fNum, Maybe [Name]
_) -> (Name
name, Int
fNum)
  [CstrShape]
cShapesSorted <- [CstrShape] -> Q [([Any] -> Q [Any], CstrShape)]
EntriesTransp
cReordering [CstrShape]
cShapes Q [([Any] -> Q [Any], CstrShape)]
-> ([([Any] -> Q [Any], CstrShape)] -> [CstrShape])
-> Q [CstrShape]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (([Any] -> Q [Any], CstrShape) -> CstrShape)
-> [([Any] -> Q [Any], CstrShape)] -> [CstrShape]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map \([Any] -> Q [Any]
_fReorder, CstrShape
cShape) -> CstrShape
cShape
  [CstrDepth]
treeDepths <- GenericStrategy -> [CstrShape] -> Q [CstrDepth]
gsEvalDepths GenericStrategy
genStrategy [CstrShape]
cShapesSorted
  [NamedCstrDepths]
weightedConstrs <- EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs EntriesTransp
cReordering [CstrDepth]
treeDepths [CstrShape]
cShapes

  -- If no 'Rep' type was given, derive one.
  let repType :: TypeQ
repType =
        TypeQ -> (Type -> TypeQ) -> Maybe Type -> TypeQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ
makeUnbalancedRep Name
typeName [CstrDepth]
treeDepths EntriesTransp
cReordering (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
derivedType))
          Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          Maybe Type
maybeRepType

  -- produce the Generic instance
  Dec
res <- Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''G.Generic TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
derivedType)
    [ Q TySynEqn -> Q Dec
forall (m :: * -> *). Quote m => m TySynEqn -> m Dec
tySynInstD (Q TySynEqn -> Q Dec) -> (TypeQ -> Q TySynEqn) -> TypeQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [TyVarBndr ()] -> TypeQ -> TypeQ -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''G.Rep TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
derivedType) (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
        TypeQ
repType
    , [NamedCstrDepths] -> Q Dec
makeUnbalancedFrom [NamedCstrDepths]
weightedConstrs
    , [NamedCstrDepths] -> Q Dec
makeUnbalancedTo [NamedCstrDepths]
weightedConstrs
    ]
  return [Dec
res]

-- | Apply a reordering strategy.
--
-- This uses given @[CstrNames]@ to understand how constructors and their
-- fields should be reordered, and applies the same transposition to entries
-- within 'EntriesTransp'.
reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp
reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp
reorderCstrs GenericStrategy{[CstrShape] -> Q [CstrDepth]
forall a. [(Text, a)] -> Q [a]
forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
gsEvalDepths :: [CstrShape] -> Q [CstrDepth]
gsReorderFieldsOn :: GenericStrategy -> forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderCstrsOn :: GenericStrategy -> forall a. [(Text, a)] -> Q [a]
gsEvalDepths :: GenericStrategy -> [CstrShape] -> Q [CstrDepth]
..} [CstrNames]
cNames = \[a]
cstrEntries ->
  [(Text, ([b] -> Q [b], a))] -> Q [([b] -> Q [b], a)]
forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn ([(Text, ([b] -> Q [b], a))] -> Q [([b] -> Q [b], a)])
-> [(Text, ([b] -> Q [b], a))] -> Q [([b] -> Q [b], a)]
forall a b. (a -> b) -> a -> b
$
    [CstrNames] -> [a] -> [(CstrNames, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CstrNames]
cNames [a]
cstrEntries [(CstrNames, a)]
-> ((CstrNames, a) -> (Text, ([b] -> Q [b], a)))
-> [(Text, ([b] -> Q [b], a))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(cstrName :: CstrNames
cstrName@(Name
name, Int
_, Maybe [Name]
_), a
cstrEntry) ->
      (Name -> Text
origName Name
name, (CstrNames -> [b] -> Q [b]
forall b. CstrNames -> [b] -> Q [b]
fieldsReorder CstrNames
cstrName, a
cstrEntry))
  where
    fieldsReorder :: CstrNames -> [b] -> Q [b]
    fieldsReorder :: forall b. CstrNames -> [b] -> Q [b]
fieldsReorder (Name
_, Int
_, Maybe [Name]
mFieldNames) = \[b]
fieldEntries -> do
      Either [b] [(Text, b)] -> Q [b]
forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn (Either [b] [(Text, b)] -> Q [b])
-> Either [b] [(Text, b)] -> Q [b]
forall a b. (a -> b) -> a -> b
$
        ([b] -> Either [b] [(Text, b)])
-> ([Name] -> [b] -> Either [b] [(Text, b)])
-> Maybe [Name]
-> [b]
-> Either [b] [(Text, b)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [b] -> Either [b] [(Text, b)]
forall a b. a -> Either a b
Left ([(Text, b)] -> Either [b] [(Text, b)]
forall a b. b -> Either a b
Right ([(Text, b)] -> Either [b] [(Text, b)])
-> ([Name] -> [b] -> [(Text, b)])
-> [Name]
-> [b]
-> Either [b] [(Text, b)]
forall a b c. SuperComposition a b c => a -> b -> c
... [Text] -> [b] -> [(Text, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Text] -> [b] -> [(Text, b)])
-> ([Name] -> [Text]) -> [Name] -> [b] -> [(Text, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Text) -> [Name] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> Text
origName) Maybe [Name]
mFieldNames [b]
fieldEntries

-- | Reifies info from a type name (given as a 'String').
-- The lookup happens from the current splice's scope (see 'lookupTypeName') and
-- the only accepted result is a "plain" data type (no GADTs).
reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr ()], [Con])
reifyDataType :: Name -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
reifyDataType Name
typeName = do
  Info
typeInfo <- Name -> Q Info
reify Name
typeName
  case Info
typeInfo of
    TyConI (DataD [Type]
decCxt Name
typeName' [TyVarBndr ()]
vars Maybe Type
mKind [Con]
constrs [DerivClause]
_) ->
      (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
-> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typeName', [Type]
decCxt, Maybe Type
mKind, [TyVarBndr ()]
vars, [Con]
constrs)
    TyConI (NewtypeD [Type]
decCxt Name
typeName' [TyVarBndr ()]
vars Maybe Type
mKind Con
constr [DerivClause]
_) ->
      (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
-> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typeName', [Type]
decCxt, Maybe Type
mKind, [TyVarBndr ()]
vars, [Con
constr])
    Info
_ -> String -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con]))
-> String -> Q (Name, [Type], Maybe Type, [TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$
      String
"Only plain datatypes are supported for derivation, but '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
      Name -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Name
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' instead reifies to:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Info -> Doc
forall a. Ppr a => a -> Doc
ppr Info
typeInfo)

-- | Derives, as well as possible, a type definition from its name, its kind
-- (where known) and its variables.
deriveFullType :: Name -> Maybe Kind -> [TyVarBndr flag] -> TypeQ
deriveFullType :: forall flag. Name -> Maybe Type -> [TyVarBndr flag] -> TypeQ
deriveFullType Name
tName Maybe Type
mKind = TypeQ -> TypeQ
addTypeSig (TypeQ -> TypeQ)
-> ([TyVarBndr flag] -> TypeQ) -> [TyVarBndr flag] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> Element [TypeQ] -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl TypeQ -> Element [TypeQ] -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tName) ([TypeQ] -> TypeQ)
-> ([TyVarBndr flag] -> [TypeQ]) -> [TyVarBndr flag] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr flag] -> [TypeQ]
forall flag. [TyVarBndr flag] -> [TypeQ]
makeVarsType
  where
    addTypeSig :: TypeQ -> TypeQ
    addTypeSig :: TypeQ -> TypeQ
addTypeSig = (TypeQ -> Type -> TypeQ) -> Type -> TypeQ -> TypeQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeQ -> Type -> TypeQ
forall (m :: * -> *). Quote m => m Type -> Type -> m Type
sigT (Type -> TypeQ -> TypeQ) -> Type -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
StarT Maybe Type
mKind

    makeVarsType :: [TyVarBndr flag] -> [TypeQ]
    makeVarsType :: forall flag. [TyVarBndr flag] -> [TypeQ]
makeVarsType = (TyVarBndr flag -> TypeQ) -> [TyVarBndr flag] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((TyVarBndr flag -> TypeQ) -> [TyVarBndr flag] -> [TypeQ])
-> (TyVarBndr flag -> TypeQ) -> [TyVarBndr flag] -> [TypeQ]
forall a b. (a -> b) -> a -> b
$ \case
      PlainTV Name
vName flag
_       -> Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
vName
      KindedTV Name
vName flag
_ Type
kind -> TypeQ -> Type -> TypeQ
forall (m :: * -> *). Quote m => m Type -> Type -> m Type
sigT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
vName) Type
kind

-- | Extract the info for each of the given constructors.
cstrNames :: [Con] -> Q [CstrNames]
cstrNames :: [Con] -> Q [CstrNames]
cstrNames [Con]
constructors = [Con] -> (Con -> Q CstrNames) -> Q [CstrNames]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Con]
constructors ((Con -> Q CstrNames) -> Q [CstrNames])
-> (Con -> Q CstrNames) -> Q [CstrNames]
forall a b. (a -> b) -> a -> b
$ \case
  NormalC Name
name [BangType]
lst -> CstrNames -> Q CstrNames
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, [BangType] -> Int
forall t. Container t => t -> Int
length [BangType]
lst, Maybe [Name]
forall a. Maybe a
Nothing)
  RecC Name
name [VarBangType]
lst    -> CstrNames -> Q CstrNames
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, [VarBangType] -> Int
forall t. Container t => t -> Int
length [VarBangType]
lst, [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ [VarBangType]
lst [VarBangType] -> Getting (Endo [Name]) [VarBangType] Name -> [Name]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (VarBangType -> Const (Endo [Name]) VarBangType)
-> [VarBangType] -> Const (Endo [Name]) [VarBangType]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed ((VarBangType -> Const (Endo [Name]) VarBangType)
 -> [VarBangType] -> Const (Endo [Name]) [VarBangType])
-> ((Name -> Const (Endo [Name]) Name)
    -> VarBangType -> Const (Endo [Name]) VarBangType)
-> Getting (Endo [Name]) [VarBangType] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> VarBangType -> Const (Endo [Name]) VarBangType
forall s t a b. Field1 s t a b => Lens s t a b
_1)
  InfixC BangType
_ Name
name BangType
_  -> CstrNames -> Q CstrNames
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Int
2, Maybe [Name]
forall a. Maybe a
Nothing)
  Con
constr           -> String -> Q CstrNames
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q CstrNames) -> String -> Q CstrNames
forall a b. (a -> b) -> a -> b
$ String
"Unsupported constructor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Con -> Doc
forall a. Ppr a => a -> Doc
ppr Con
constr)

-- | Combines depths with constructors, 'fail'ing in case of mismatches, and
-- generates 'Name's for the constructors' arguments.
makeWeightedConstrs
  :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs EntriesTransp
cReorder [CstrDepth]
treeDepths [CstrShape]
cShapes = do
  [([Name] -> Q [Name], CstrShape)]
reorderedShapes <- [CstrShape] -> Q [([Name] -> Q [Name], CstrShape)]
EntriesTransp
cReorder [CstrShape]
cShapes
  [(CstrDepth, ([Name] -> Q [Name], CstrShape))]
-> ((CstrDepth, ([Name] -> Q [Name], CstrShape))
    -> Q NamedCstrDepths)
-> Q [NamedCstrDepths]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([CstrDepth]
-> [([Name] -> Q [Name], CstrShape)]
-> [(CstrDepth, ([Name] -> Q [Name], CstrShape))]
forall a b. [a] -> [b] -> [(a, b)]
zip [CstrDepth]
treeDepths [([Name] -> Q [Name], CstrShape)]
reorderedShapes) (((CstrDepth, ([Name] -> Q [Name], CstrShape))
  -> Q NamedCstrDepths)
 -> Q [NamedCstrDepths])
-> ((CstrDepth, ([Name] -> Q [Name], CstrShape))
    -> Q NamedCstrDepths)
-> Q [NamedCstrDepths]
forall a b. (a -> b) -> a -> b
$
    \((Natural
cDepth, [Natural]
fDepths), ([Name] -> Q [Name]
fReorder, (Name
cName, Int
fNum))) -> do
      [Name]
fieldVarsNames <- [Int] -> (Int -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] \Int
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Int
i)
      [Name]
reorderedFieldVarNames <- [Name] -> Q [Name]
fReorder [Name]
fieldVarsNames
      return NCD :: Natural -> Name -> [Name] -> [(Natural, Name)] -> NamedCstrDepths
NCD
        { ncdCstrDepth :: Natural
ncdCstrDepth = Natural
cDepth
        , ncdCstrName :: Name
ncdCstrName = Name
cName
        , ncdOrigFieldNames :: [Name]
ncdOrigFieldNames = [Name]
fieldVarsNames
        , ncdFields :: [(Natural, Name)]
ncdFields = [Natural] -> [Name] -> [(Natural, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural]
fDepths [Name]
reorderedFieldVarNames
        }

-- | Creates the 'G.Rep' type for an unbalanced 'G.Generic' instance, for a type
-- given its name, constructors' depths and derived full type.
--
-- Note: given that these types definition can be very complex to generate,
-- especially in the metadata, here we let @generic-deriving@ make a balanced
-- value first (see 'makeRep0Inline') and then de-balance the result.
makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ
makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ
makeUnbalancedRep Name
typeName [CstrDepth]
treeDepths EntriesTransp
reorderConstrs TypeQ
derivedType = do
  -- let generic-deriving create the balanced type first
  Type
balRep <- Name -> TypeQ -> TypeQ
makeRep0Inline Name
typeName TypeQ
derivedType
  -- separate the top-most type metadata from the constructors' trees
  (Type
typeMd, [Type]
constrTypes) <- TypeQ -> Type -> Q (Type, [Type])
dismantleGenericTree [t| G.C1 |] Type
balRep
  -- for each of the constructor's trees
  [([Type] -> Q [Type], Type)]
reorderedConstrTypes <- [Type] -> Q [([Type] -> Q [Type], Type)]
EntriesTransp
reorderConstrs [Type]
constrTypes
  [(Natural, Type)]
unbalConstrs <- [(([Type] -> Q [Type], Type), CstrDepth)]
-> ((([Type] -> Q [Type], Type), CstrDepth) -> Q (Natural, Type))
-> Q [(Natural, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([([Type] -> Q [Type], Type)]
-> [CstrDepth] -> [(([Type] -> Q [Type], Type), CstrDepth)]
forall a b. [a] -> [b] -> [(a, b)]
zip [([Type] -> Q [Type], Type)]
reorderedConstrTypes [CstrDepth]
treeDepths) (((([Type] -> Q [Type], Type), CstrDepth) -> Q (Natural, Type))
 -> Q [(Natural, Type)])
-> ((([Type] -> Q [Type], Type), CstrDepth) -> Q (Natural, Type))
-> Q [(Natural, Type)]
forall a b. (a -> b) -> a -> b
$
    \(([Type] -> Q [Type]
reorderFields, Type
constrType), CstrDepth
treeDepth) ->
    case CstrDepth
treeDepth of
      (Natural
n, []) ->
        -- when there are no fields there is no tree to unbalance
        (Natural, Type) -> Q (Natural, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural
n, Type
constrType)
      (Natural
n, [Natural]
fieldDepths) -> do
        -- separate the top-most constructor metadata from the fields' trees
        (Type
constrMd, [Type]
fieldTypes) <- TypeQ -> Type -> Q (Type, [Type])
dismantleGenericTree [t| G.S1 |] Type
constrType
        -- build the unbalanced tree of fields
        [Type]
reorderedFieldTypes <- [Type] -> Q [Type]
reorderFields [Type]
fieldTypes
        Type
unbalConstRes <- [(Natural, Type)] -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold ([Natural] -> [Type] -> [(Natural, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural]
fieldDepths [Type]
reorderedFieldTypes)
                                        (TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeQ -> TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''(G.:*:)))
        -- return the new unbalanced constructor
        return (Natural
n, Type -> Type -> Type
AppT Type
constrMd Type
unbalConstRes)
  -- build the unbalanced tree of constructors and rebuild the type
  TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typeMd) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ [(Natural, Type)] -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Type)]
unbalConstrs (TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeQ -> TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''(G.:+:)))

-- | Breaks down a tree of @Generic@ types from the contructor of "nodes" and
-- the constructor for "leaves" metadata.
--
-- This expects (and should always be the case) the "root" to be a @Generic@
-- metadata contructor, which is returned in the result alongside the list of
-- leaves (in order).
dismantleGenericTree :: TypeQ -> Type -> Q (Type, [Type])
dismantleGenericTree :: TypeQ -> Type -> Q (Type, [Type])
dismantleGenericTree TypeQ
leafMetaQ (AppT Type
meta Type
nodes) = do
  Type
leafMeta <- TypeQ
leafMetaQ
  let collectLeafsTypes :: Type -> [Type]
      collectLeafsTypes :: Type -> [Type]
collectLeafsTypes Type
tp =
        case Type
tp of
          Type
f `AppT` Type
_ `AppT` Type
_ | Type
f Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
leafMeta -> [Type
tp]
          AppT Type
a Type
b -> Type -> [Type]
collectLeafsTypes Type
a [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> Type -> [Type]
collectLeafsTypes Type
b
          Type
_ -> []
  (Type, [Type]) -> Q (Type, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
meta, Type -> [Type]
collectLeafsTypes Type
nodes)
dismantleGenericTree TypeQ
_ Type
x = String -> Q (Type, [Type])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, [Type])) -> String -> Q (Type, [Type])
forall a b. (a -> b) -> a -> b
$
  String
"Unexpected lack of Generic Metadata: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
x)

-- | Create the unbalanced 'G.from' fuction declaration for a type starting from
-- its list of weighted constructors.
makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ
makeUnbalancedFrom :: [NamedCstrDepths] -> Q Dec
makeUnbalancedFrom [NamedCstrDepths]
wConstrs = do
  ([Pat]
cPatts, [(Natural, [Exp])]
cDepthExp) <- ([(Pat, (Natural, [Exp]))] -> ([Pat], [(Natural, [Exp])]))
-> Q [(Pat, (Natural, [Exp]))] -> Q ([Pat], [(Natural, [Exp])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, (Natural, [Exp]))] -> ([Pat], [(Natural, [Exp])])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, (Natural, [Exp]))] -> Q ([Pat], [(Natural, [Exp])]))
-> ((NamedCstrDepths -> Q (Pat, (Natural, [Exp])))
    -> Q [(Pat, (Natural, [Exp]))])
-> (NamedCstrDepths -> Q (Pat, (Natural, [Exp])))
-> Q ([Pat], [(Natural, [Exp])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NamedCstrDepths]
-> (NamedCstrDepths -> Q (Pat, (Natural, [Exp])))
-> Q [(Pat, (Natural, [Exp]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamedCstrDepths]
wConstrs ((NamedCstrDepths -> Q (Pat, (Natural, [Exp])))
 -> Q ([Pat], [(Natural, [Exp])]))
-> (NamedCstrDepths -> Q (Pat, (Natural, [Exp])))
-> Q ([Pat], [(Natural, [Exp])])
forall a b. (a -> b) -> a -> b
$ \(NCD Natural
cDepth Name
cName [Name]
wOrigFields [(Natural, Name)]
wFields) -> do
    [(Natural, Exp)]
fDepthExp <- [(Natural, Name)]
-> ((Natural, Name) -> Q (Natural, Exp)) -> Q [(Natural, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Natural, Name)]
wFields (((Natural, Name) -> Q (Natural, Exp)) -> Q [(Natural, Exp)])
-> ((Natural, Name) -> Q (Natural, Exp)) -> Q [(Natural, Exp)]
forall a b. (a -> b) -> a -> b
$ \(Natural
fDepth, Name
fName) -> do
      -- make expression to asseble a Generic Field from its variable
      Exp
fExpr <- Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.M1 |] (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.K1 |] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName
      return (Natural
fDepth, Exp
fExpr)
    -- make pattern for this constructor
    [Pat]
fPatts <- (Name -> Q Pat) -> [Name] -> Q [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
wOrigFields
    let cPatt :: Pat
cPatt = Name -> [Pat] -> Pat
ConP Name
cName [Pat]
fPatts
    -- make expression to assemble its fields as an isolated Generic Constructor
    Exp
cExp <- Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.M1 |] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ case [(Natural, Exp)]
fDepthExp of
      [] -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'G.U1
      [(Natural, Exp)]
_  -> [(Natural, Exp)] -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Exp)]
fDepthExp (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| (G.:*:) |])
    return (Pat
cPatt, (Natural
cDepth, [Exp
cExp]))
  -- make expressions to assemble all Generic Constructors
  [Exp]
cExps <- (Q Exp -> Q Exp) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.M1 |]) (Q [Exp] -> Q [Exp]) -> Q [Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ [(Natural, [Exp])] -> (Q [Exp] -> Q [Exp] -> Q [Exp]) -> Q [Exp]
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, [Exp])]
cDepthExp ((Q [Exp] -> Q [Exp] -> Q [Exp]) -> Q [Exp])
-> (Q [Exp] -> Q [Exp] -> Q [Exp]) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Q [Exp]
xs Q [Exp]
ys ->
    [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
(<>) ([Exp] -> [Exp] -> [Exp]) -> Q [Exp] -> Q ([Exp] -> [Exp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Exp -> Q Exp) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.L1 |]) Q [Exp]
xs Q ([Exp] -> [Exp]) -> Q [Exp] -> Q [Exp]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| G.R1 |]) Q [Exp]
ys
  -- make function definition
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'G.from ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$ (Pat -> Exp -> Q Clause) -> [Pat] -> [Exp] -> [Q Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Pat
p Exp
e -> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e) []) [Pat]
cPatts [Exp]
cExps

-- | Create the unbalanced 'G.to' fuction declaration for a type starting from
-- its list of weighted constructors.
makeUnbalancedTo :: [NamedCstrDepths] -> DecQ
makeUnbalancedTo :: [NamedCstrDepths] -> Q Dec
makeUnbalancedTo [NamedCstrDepths]
wConstrs = do
  ([Exp]
cExps, [(Natural, [Pat])]
cDepthPat) <- ([(Exp, (Natural, [Pat]))] -> ([Exp], [(Natural, [Pat])]))
-> Q [(Exp, (Natural, [Pat]))] -> Q ([Exp], [(Natural, [Pat])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Exp, (Natural, [Pat]))] -> ([Exp], [(Natural, [Pat])])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Exp, (Natural, [Pat]))] -> Q ([Exp], [(Natural, [Pat])]))
-> ((NamedCstrDepths -> Q (Exp, (Natural, [Pat])))
    -> Q [(Exp, (Natural, [Pat]))])
-> (NamedCstrDepths -> Q (Exp, (Natural, [Pat])))
-> Q ([Exp], [(Natural, [Pat])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NamedCstrDepths]
-> (NamedCstrDepths -> Q (Exp, (Natural, [Pat])))
-> Q [(Exp, (Natural, [Pat]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamedCstrDepths]
wConstrs ((NamedCstrDepths -> Q (Exp, (Natural, [Pat])))
 -> Q ([Exp], [(Natural, [Pat])]))
-> (NamedCstrDepths -> Q (Exp, (Natural, [Pat])))
-> Q ([Exp], [(Natural, [Pat])])
forall a b. (a -> b) -> a -> b
$ \(NCD Natural
cDepth Name
cName [Name]
wOrigFields [(Natural, Name)]
wFields) -> do
    [(Natural, Pat)]
fDepthPat <- [(Natural, Name)]
-> ((Natural, Name) -> Q (Natural, Pat)) -> Q [(Natural, Pat)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Natural, Name)]
wFields (((Natural, Name) -> Q (Natural, Pat)) -> Q [(Natural, Pat)])
-> ((Natural, Name) -> Q (Natural, Pat)) -> Q [(Natural, Pat)]
forall a b. (a -> b) -> a -> b
$ \(Natural
fDepth, Name
fName) -> do
      -- make pattern for a Generic Field from its variable
      Pat
fPatt <- Name -> Q Pat -> Q Pat
conP1 'G.M1 (Q Pat -> Q Pat) -> (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Pat -> Q Pat
conP1 'G.K1 (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fName
      return (Natural
fDepth, Pat
fPatt)
    -- make pattern for this isolated Generic Constructor
    Pat
cPatt <- Name -> Q Pat -> Q Pat
conP1 'G.M1 (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ case [(Natural, Pat)]
fDepthPat of
      [] -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'G.U1 []
      [(Natural, Pat)]
_  -> [(Natural, Pat)] -> (Q Pat -> Q Pat -> Q Pat) -> Q Pat
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Pat)]
fDepthPat (Name -> Q Pat -> Q Pat -> Q Pat
conP2 '(G.:*:))
    -- make expression to assemble this constructor
    [Exp]
fExps <- (Name -> Q Exp) -> [Name] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
wOrigFields
    let cExp :: Exp
cExp = (Exp -> Element [Exp] -> Exp) -> Exp -> [Exp] -> Exp
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl Exp -> Exp -> Exp
Exp -> Element [Exp] -> Exp
AppE (Name -> Exp
ConE Name
cName) [Exp]
fExps
    return (Exp
cExp, (Natural
cDepth, [Pat
cPatt]))
  -- make patterns for all Generic Constructors
  [Pat]
cPatts <- (Q Pat -> Q Pat) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> Q Pat -> Q Pat
conP1 'G.M1) (Q [Pat] -> Q [Pat]) -> Q [Pat] -> Q [Pat]
forall a b. (a -> b) -> a -> b
$ [(Natural, [Pat])] -> (Q [Pat] -> Q [Pat] -> Q [Pat]) -> Q [Pat]
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, [Pat])]
cDepthPat ((Q [Pat] -> Q [Pat] -> Q [Pat]) -> Q [Pat])
-> (Q [Pat] -> Q [Pat] -> Q [Pat]) -> Q [Pat]
forall a b. (a -> b) -> a -> b
$ \Q [Pat]
xs Q [Pat]
ys ->
    [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
(<>) ([Pat] -> [Pat] -> [Pat]) -> Q [Pat] -> Q ([Pat] -> [Pat])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Pat -> Q Pat) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> Q Pat -> Q Pat
conP1 'G.L1) Q [Pat]
xs Q ([Pat] -> [Pat]) -> Q [Pat] -> Q [Pat]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Pat -> Q Pat) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> Q Pat -> Q Pat
conP1 'G.R1) Q [Pat]
ys
  -- make function definition
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'G.to ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$ (Pat -> Exp -> Q Clause) -> [Pat] -> [Exp] -> [Q Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Pat
p Exp
e -> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e) []) [Pat]
cPatts [Exp]
cExps

-- | Recursively aggregates the values in the given list by merging (with the
-- given function) the ones that are adjacent and with the same depth.
--
-- This will fail for every case in which the list cannot be folded into a single
-- 0-depth value.
unbalancedFold :: forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold :: forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, a)]
lst Q a -> Q a -> Q a
f = [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldRec [(Natural, a)]
lst Q [(Natural, a)] -> ([(Natural, a)] -> Q a) -> Q a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [(Natural
0, a
result)] -> a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
  [(Natural
n, a
_)] -> String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
    String
"Resulting unbalanced tree has a single root, but of depth " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Natural
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" instead of 0. Check your depths definitions."
  [(Natural, a)]
_ -> String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
    String
"Cannot create a tree from nodes of depths: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (((Natural, a) -> Text) -> [(Natural, a)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show @Text (Natural -> Text)
-> ((Natural, a) -> Natural) -> (Natural, a) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, a) -> Natural
forall a b. (a, b) -> a
fst) [(Natural, a)]
lst) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
". Check your depths definitions."
  where
    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]
    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldRec [(Natural, a)]
xs = do
      [(Natural, a)]
ys <- [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldSingle [(Natural, a)]
xs
      if [(Natural, a)]
xs [(Natural, a)] -> [(Natural, a)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Natural, a)]
ys then [(Natural, a)] -> Q [(Natural, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Natural, a)]
xs else [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldRec [(Natural, a)]
ys

    unbalancedFoldSingle :: [(Natural, a)] -> Q [(Natural, a)]
    unbalancedFoldSingle :: [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldSingle = \case
      [] -> [(Natural, a)] -> Q [(Natural, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      (Natural
dx, a
x) : (Natural
dy, a
y) : [(Natural, a)]
xs | Natural
dx Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
dy -> do
        a
dxy <- Q a -> Q a -> Q a
f (a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y)
        return $ (Natural
dx Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1, a
dxy) (Natural, a) -> [(Natural, a)] -> [(Natural, a)]
forall a. a -> [a] -> [a]
: [(Natural, a)]
xs
      (Natural, a)
x : [(Natural, a)]
xs -> do
        [(Natural, a)]
ys <- [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldSingle [(Natural, a)]
xs
        return ((Natural, a)
x (Natural, a) -> [(Natural, a)] -> [(Natural, a)]
forall a. a -> [a] -> [a]
: [(Natural, a)]
ys)

----------------------------------------------------------------------------
-- Utility functions
----------------------------------------------------------------------------

conP1 :: Name -> PatQ -> PatQ
conP1 :: Name -> Q Pat -> Q Pat
conP1 Name
name Q Pat
pat = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name [Q Pat
pat]

conP2 :: Name -> PatQ -> PatQ -> PatQ
conP2 :: Name -> Q Pat -> Q Pat -> Q Pat
conP2 Name
name Q Pat
pat1 Q Pat
pat2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name [Q Pat
pat1, Q Pat
pat2]

mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]
mapQ :: forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ Q a -> Q a
f Q [a]
qlst = Q [a]
qlst Q [a] -> ([a] -> Q [a]) -> Q [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> Q a) -> [a] -> Q [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q a -> Q a
f (Q a -> Q a) -> (a -> Q a) -> a -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- | Original name of a constructor or field.
origName :: Name -> Text
origName :: Name -> Text
origName = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase


-- | Patch a given strategy by applying a transformation function to constructor names
-- before passing them through ordering function.
mangleGenericStrategyConstructors :: (Text -> Text) -> GenericStrategy -> GenericStrategy
mangleGenericStrategyConstructors :: (Text -> Text) -> GenericStrategy -> GenericStrategy
mangleGenericStrategyConstructors Text -> Text
modCstr GenericStrategy
gs = GenericStrategy
gs
  { gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn = GenericStrategy -> forall a. [(Text, a)] -> Q [a]
gsReorderCstrsOn GenericStrategy
gs ([(Text, a)] -> Q [a])
-> ([(Text, a)] -> [(Text, a)]) -> [(Text, a)] -> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> (Text, a)) -> [(Text, a)] -> [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> (Text, a) -> (Text, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
modCstr) }

-- | Patch a given strategy by applying a transformation function to field names
-- before passing them through ordering function.
mangleGenericStrategyFields :: (Text -> Text) -> GenericStrategy -> GenericStrategy
mangleGenericStrategyFields :: (Text -> Text) -> GenericStrategy -> GenericStrategy
mangleGenericStrategyFields Text -> Text
modField GenericStrategy
gs = GenericStrategy
gs
  { gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn = GenericStrategy -> forall a. Either [a] [(Text, a)] -> Q [a]
gsReorderFieldsOn GenericStrategy
gs (Either [a] [(Text, a)] -> Q [a])
-> (Either [a] [(Text, a)] -> Either [a] [(Text, a)])
-> Either [a] [(Text, a)]
-> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, a)] -> [(Text, a)])
-> Either [a] [(Text, a)] -> Either [a] [(Text, a)]
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((Text, a) -> (Text, a)) -> [(Text, a)] -> [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> (Text, a) -> (Text, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
modField)) }