-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
--
-- | Generic deriving with unbalanced trees.

module 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

    -- * Internals
  , reifyDataType
  , deriveFullType
  , customGeneric'
  ) where

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

----------------------------------------------------------------------------
-- 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 treeDepths :: [CstrDepth]
treeDepths = ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy (([CstrShape] -> Q [CstrDepth]) -> GenericStrategy)
-> ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
forall a b. (a -> b) -> a -> b
$ \cstrShape :: [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
    "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
$ \(fDepths, (constrName, 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
$
    "Number of fields' depths does not match number of field for data " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    "constructor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall b 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 reorder :: forall a. [(Text, a)] -> Q [a]
reorder gs :: 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 reorderUnnamed :: UnnamedEntriesReorder
reorderUnnamed reorder :: forall a. [(Text, a)] -> Q [a]
reorder gs :: 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 reorderUnnamed :: UnnamedEntriesReorder
reorderUnnamed reorder :: 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 :: [(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 :: [a] -> Q [a]
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 :: [a] -> Q [a]
forbidUnnamedFields fields :: [a]
fields =
  if [a] -> Int
forall t. Container t => t -> Int
length [a]
fields Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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 "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 mkDepths :: [CstrShape] -> Q [CstrDepth]
mkDepths = $WGenericStrategy :: ([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 dStrategy :: Int -> [Natural]
dStrategy = ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
simpleGenericStrategy (([CstrShape] -> Q [CstrDepth]) -> GenericStrategy)
-> ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
forall a b. (a -> b) -> a -> b
$ \cShapes :: [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]
dStrategy (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]
dStrategy (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 n :: 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) [] [1..Int
n]
  where
    addRightBalDepth :: [Natural] -> [Natural]
    addRightBalDepth :: [Natural] -> [Natural]
addRightBalDepth = \case
      [] -> [0]
      [x :: Natural
x] -> [Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ 1, Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ 1]
      (x :: Natural
x : y :: Natural
y : xs :: [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)
      (_ : y :: Natural
y : xs :: [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 0 = []
makeLeftCombDepths n :: Int
n = (Int -> Natural) -> [Int] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Natural]) -> [Int] -> [Natural]
forall a b. (a -> b) -> a -> b
$ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2..1]

makeHaskellDepths :: Int -> [Natural]
makeHaskellDepths :: Int -> [Natural]
makeHaskellDepths n :: 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 [0]) of
    Nothing -> []
    Just leaves :: NonEmpty [Natural]
leaves -> (Natural -> [Natural] -> [Natural] -> [Natural])
-> NonEmpty [Natural] -> [Natural]
forall a. (Natural -> a -> a -> a) -> NonEmpty a -> a
mkGenericTree (\_ l :: [Natural]
l r :: [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 :: [Natural] -> CstrDepth
cstr flds :: [Natural]
flds = (Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). 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 :: 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
$ Proxy n
forall k (t :: k). 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 typeStr :: String
typeStr genStrategy :: 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
  (typeName :: Name
typeName, _, mKind :: Maybe Kind
mKind, vars :: [TyVarBndr]
vars, constructors :: [Con]
constructors) <- String -> Q Name
lookupTypeNameOrFail String
typeStr Q Name
-> (Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con]))
-> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
reifyDataType
  -- obtain info about its constructor and desired tree
  Kind
derivedType <- Name -> Maybe Kind -> [TyVarBndr] -> TypeQ
deriveFullType Name
typeName Maybe Kind
mKind [TyVarBndr]
vars
  Maybe Kind -> Name -> Kind -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' Maybe Kind
forall a. Maybe a
Nothing Name
typeName Kind
derivedType  [Con]
constructors GenericStrategy
genStrategy

-- | If a 'Rep' 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 'Rep' instance as well.
customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' :: Maybe Kind -> Name -> Kind -> [Con] -> GenericStrategy -> Q [Dec]
customGeneric' maybeRepType :: Maybe Kind
maybeRepType typeName :: Name
typeName derivedType :: Kind
derivedType constructors :: [Con]
constructors genStrategy :: GenericStrategy
genStrategy = do
  [CstrNames]
cNames <- [Con] -> Q [CstrNames]
cstrNames [Con]
constructors
  let cReordering :: EntriesTransp
      cReordering :: [a] -> Q [([b] -> Q [b], a)]
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
name, fNum :: Int
fNum, _) -> (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 \(_fReorder :: [Any] -> Q [Any]
_fReorder, cShape :: 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]
cShapesSorted

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

  -- produce the Generic instance
  Dec
res <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Name -> TypeQ
conT ''G.Generic TypeQ -> TypeQ -> TypeQ
`appT` Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
derivedType)
    [ TySynEqnQ -> DecQ
tySynInstD (TySynEqnQ -> DecQ) -> (TypeQ -> TySynEqnQ) -> TypeQ -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [TyVarBndr] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> TypeQ
conT ''G.Rep TypeQ -> TypeQ -> TypeQ
`appT` Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
derivedType) (TypeQ -> DecQ) -> TypeQ -> DecQ
forall a b. (a -> b) -> a -> b
$
        TypeQ
repType
    , [NamedCstrDepths] -> DecQ
makeUnbalancedFrom [NamedCstrDepths]
weightedConstrs
    , [NamedCstrDepths] -> DecQ
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{..} cNames :: [CstrNames]
cNames = \cstrEntries :: [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
name, _, _), cstrEntry :: 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 :: CstrNames -> [b] -> Q [b]
fieldsReorder (_, _, mFieldNames :: Maybe [Name]
mFieldNames) = \fieldEntries :: [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, Cxt, Maybe Kind, [TyVarBndr], [Con])
reifyDataType typeName :: Name
typeName = do
  Info
typeInfo <- Name -> Q Info
reify Name
typeName
  case Info
typeInfo of
    TyConI (DataD decCxt :: Cxt
decCxt typeName' :: Name
typeName' vars :: [TyVarBndr]
vars mKind :: Maybe Kind
mKind constrs :: [Con]
constrs _) ->
      (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
-> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typeName', Cxt
decCxt, Maybe Kind
mKind, [TyVarBndr]
vars, [Con]
constrs)
    _ -> String -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con]))
-> String -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$
      "Only plain datatypes are supported for derivation, but '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
      Name -> String
forall b a. (Show a, IsString b) => a -> b
show Name
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "' instead reifies to:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall b a. (Show a, IsString b) => a -> b
show 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] -> TypeQ
deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ
deriveFullType tName :: Name
tName mKind :: Maybe Kind
mKind = TypeQ -> TypeQ
addTypeSig (TypeQ -> TypeQ) -> ([TyVarBndr] -> TypeQ) -> [TyVarBndr] -> 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 -> TypeQ -> TypeQ
TypeQ -> Element [TypeQ] -> TypeQ
appT (Name -> TypeQ
conT Name
tName) ([TypeQ] -> TypeQ)
-> ([TyVarBndr] -> [TypeQ]) -> [TyVarBndr] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr] -> [TypeQ]
makeVarsType
  where
    addTypeSig :: TypeQ -> TypeQ
    addTypeSig :: TypeQ -> TypeQ
addTypeSig = (TypeQ -> Kind -> TypeQ) -> Kind -> TypeQ -> TypeQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeQ -> Kind -> TypeQ
sigT (Kind -> TypeQ -> TypeQ) -> Kind -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
StarT Maybe Kind
mKind

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

-- | Extract the info for each of the given constructors.
cstrNames :: [Con] -> Q [CstrNames]
cstrNames :: [Con] -> Q [CstrNames]
cstrNames constructors :: [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
name lst :: [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
name lst :: [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 _ name :: Name
name _  -> CstrNames -> Q CstrNames
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, 2, Maybe [Name]
forall a. Maybe a
Nothing)
  constr :: 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
$ "Unsupported constructor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall b a. (Show a, IsString b) => a -> b
show 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 cReorder :: EntriesTransp
cReorder treeDepths :: [CstrDepth]
treeDepths cShapes :: [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
$
    \((cDepth :: Natural
cDepth, fDepths :: [Natural]
fDepths), (fReorder :: [Name] -> Q [Name]
fReorder, (cName :: Name
cName, fNum :: 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 [0 .. Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] \i :: Int
i -> String -> Q Name
newName ("v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
i)
      [Name]
reorderedFieldVarNames <- [Name] -> Q [Name]
fReorder [Name]
fieldVarsNames
      return $WNCD :: 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 typeName :: Name
typeName treeDepths :: [CstrDepth]
treeDepths reorderConstrs :: EntriesTransp
reorderConstrs derivedType :: TypeQ
derivedType = do
  -- let generic-deriving create the balanced type first
  Kind
balRep <- Name -> TypeQ -> TypeQ
makeRep0Inline Name
typeName TypeQ
derivedType
  -- separate the top-most type metadata from the constructors' trees
  (typeMd :: Kind
typeMd, constrTypes :: Cxt
constrTypes) <- TypeQ -> Kind -> Q (Kind, Cxt)
dismantleGenericTree [t| G.C1 |] Kind
balRep
  -- for each of the constructor's trees
  [(Cxt -> CxtQ, Kind)]
reorderedConstrTypes <- Cxt -> Q [(Cxt -> CxtQ, Kind)]
EntriesTransp
reorderConstrs Cxt
constrTypes
  [(Natural, Kind)]
unbalConstrs <- [((Cxt -> CxtQ, Kind), CstrDepth)]
-> (((Cxt -> CxtQ, Kind), CstrDepth) -> Q (Natural, Kind))
-> Q [(Natural, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(Cxt -> CxtQ, Kind)]
-> [CstrDepth] -> [((Cxt -> CxtQ, Kind), CstrDepth)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Cxt -> CxtQ, Kind)]
reorderedConstrTypes [CstrDepth]
treeDepths) ((((Cxt -> CxtQ, Kind), CstrDepth) -> Q (Natural, Kind))
 -> Q [(Natural, Kind)])
-> (((Cxt -> CxtQ, Kind), CstrDepth) -> Q (Natural, Kind))
-> Q [(Natural, Kind)]
forall a b. (a -> b) -> a -> b
$
    \((reorderFields :: Cxt -> CxtQ
reorderFields, constrType :: Kind
constrType), treeDepth :: CstrDepth
treeDepth) ->
    case CstrDepth
treeDepth of
      (n :: Natural
n, []) ->
        -- when there are no fields there is no tree to unbalance
        (Natural, Kind) -> Q (Natural, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural
n, Kind
constrType)
      (n :: Natural
n, fieldDepths :: [Natural]
fieldDepths) -> do
        -- separate the top-most constructor metadata from the fields' trees
        (constrMd :: Kind
constrMd, fieldTypes :: Cxt
fieldTypes) <- TypeQ -> Kind -> Q (Kind, Cxt)
dismantleGenericTree [t| G.S1 |] Kind
constrType
        -- build the unbalanced tree of fields
        Cxt
reorderedFieldTypes <- Cxt -> CxtQ
reorderFields Cxt
fieldTypes
        Kind
unbalConstRes <- [(Natural, Kind)] -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold ([Natural] -> Cxt -> [(Natural, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural]
fieldDepths Cxt
reorderedFieldTypes)
                                        (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''(G.:*:)))
        -- return the new unbalanced constructor
        return (Natural
n, Kind -> Kind -> Kind
AppT Kind
constrMd Kind
unbalConstRes)
  -- build the unbalanced tree of constructors and rebuild the type
  TypeQ -> TypeQ -> TypeQ
appT (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
typeMd) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ [(Natural, Kind)] -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Kind)]
unbalConstrs (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
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 -> Kind -> Q (Kind, Cxt)
dismantleGenericTree leafMetaQ :: TypeQ
leafMetaQ (AppT meta :: Kind
meta nodes :: Kind
nodes) = do
  Kind
leafMeta <- TypeQ
leafMetaQ
  let collectLeafsTypes :: Type -> [Type]
      collectLeafsTypes :: Kind -> Cxt
collectLeafsTypes tp :: Kind
tp =
        case Kind
tp of
          f :: Kind
f `AppT` _ `AppT` _ | Kind
f Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
leafMeta -> [Kind
tp]
          AppT a :: Kind
a b :: Kind
b -> Kind -> Cxt
collectLeafsTypes Kind
a Cxt -> Cxt -> Cxt
forall a. Semigroup a => a -> a -> a
<> Kind -> Cxt
collectLeafsTypes Kind
b
          _ -> []
  (Kind, Cxt) -> Q (Kind, Cxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
meta, Kind -> Cxt
collectLeafsTypes Kind
nodes)
dismantleGenericTree _ x :: Kind
x = String -> Q (Kind, Cxt)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Kind, Cxt)) -> String -> Q (Kind, Cxt)
forall a b. (a -> b) -> a -> b
$
  "Unexpected lack of Generic Metadata: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall b a. (Show a, IsString b) => a -> b
show Kind
x

-- | Create the unbalanced 'G.from' fuction declaration for a type starting from
-- its list of weighted constructors.
makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ
makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ
makeUnbalancedFrom wConstrs :: [NamedCstrDepths]
wConstrs = do
  (cPatts :: [Pat]
cPatts, cDepthExp :: [(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 cDepth :: Natural
cDepth cName :: Name
cName wOrigFields :: [Name]
wOrigFields wFields :: [(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
$ \(fDepth :: Natural
fDepth, fName :: Name
fName) -> do
      -- make expression to asseble a Generic Field from its variable
      Exp
fExpr <- ExpQ -> ExpQ -> ExpQ
appE [| G.M1 |] (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> ExpQ -> ExpQ
appE [| G.K1 |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
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
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 <- ExpQ -> ExpQ -> ExpQ
appE [| G.M1 |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ case [(Natural, Exp)]
fDepthExp of
      [] -> Name -> ExpQ
conE 'G.U1
      _  -> [(Natural, Exp)] -> (ExpQ -> ExpQ -> ExpQ) -> ExpQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Exp)]
fDepthExp (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> ExpQ -> ExpQ -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> ExpQ -> ExpQ
appE [| (G.:*:) |])
    return (Pat
cPatt, (Natural
cDepth, [Exp
cExp]))
  -- make expressions to assemble all Generic Constructors
  [Exp]
cExps <- (ExpQ -> ExpQ) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (ExpQ -> ExpQ -> ExpQ
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
$ \xs :: Q [Exp]
xs ys :: 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
<$> (ExpQ -> ExpQ) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (ExpQ -> ExpQ -> ExpQ
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
<*> (ExpQ -> ExpQ) -> Q [Exp] -> Q [Exp]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (ExpQ -> ExpQ -> ExpQ
appE [| G.R1 |]) Q [Exp]
ys
  -- make function definition
  Name -> [ClauseQ] -> DecQ
funD 'G.from ([ClauseQ] -> DecQ) -> [ClauseQ] -> DecQ
forall a b. (a -> b) -> a -> b
$ (Pat -> Exp -> ClauseQ) -> [Pat] -> [Exp] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\p :: Pat
p e :: Exp
e -> [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause [Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
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] -> DecQ
makeUnbalancedTo wConstrs :: [NamedCstrDepths]
wConstrs = do
  (cExps :: [Exp]
cExps, cDepthPat :: [(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 cDepth :: Natural
cDepth cName :: Name
cName wOrigFields :: [Name]
wOrigFields wFields :: [(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
$ \(fDepth :: Natural
fDepth, fName :: 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
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
conP 'G.U1 []
      _  -> [(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 -> ExpQ) -> [Name] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> ExpQ
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
$ \xs :: Q [Pat]
xs ys :: 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 -> [ClauseQ] -> DecQ
funD 'G.to ([ClauseQ] -> DecQ) -> [ClauseQ] -> DecQ
forall a b. (a -> b) -> a -> b
$ (Pat -> Exp -> ClauseQ) -> [Pat] -> [Exp] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\p :: Pat
p e :: Exp
e -> [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause [Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
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 :: [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold lst :: [(Natural, a)]
lst f :: 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
  [(0, result :: a
result)] -> a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
  [(n :: Natural
n, _)] -> 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
$
    "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. (Show a, IsString b) => a -> b
show Natural
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    " instead of 0. Check your depths definitions."
  _ -> 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
$
    "Cannot create a tree from nodes of depths: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Natural] -> String
forall b a. (Show a, IsString b) => a -> b
show (((Natural, a) -> Natural) -> [(Natural, a)] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Natural, a) -> Natural
forall a b. (a, b) -> a
fst [(Natural, a)]
lst) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    ". Check your depths definitions."
  where
    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]
    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]
unbalancedFoldRec xs :: [(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 []
      (dx :: Natural
dx, x :: a
x) : (dy :: Natural
dy, y :: a
y) : xs :: [(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
- 1, a
dxy) (Natural, a) -> [(Natural, a)] -> [(Natural, a)]
forall a. a -> [a] -> [a]
: [(Natural, a)]
xs
      x :: (Natural, a)
x : xs :: [(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
name pat :: Q Pat
pat = Name -> [Q Pat] -> Q Pat
conP Name
name [Q Pat
pat]

conP2 :: Name -> PatQ -> PatQ -> PatQ
conP2 :: Name -> Q Pat -> Q Pat -> Q Pat
conP2 name :: Name
name pat1 :: Q Pat
pat1 pat2 :: Q Pat
pat2 = Name -> [Q Pat] -> Q Pat
conP Name
name [Q Pat
pat1, Q Pat
pat2]

mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]
mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]
mapQ f :: Q a -> Q a
f qlst :: 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