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

module Util.CustomGeneric
  ( -- * Custom Generic strategies
    withDepths
  , rightBalanced
  , leftBalanced
  , rightComb
  , leftComb
    -- * Depth usage helpers
  , cstr
  , fld
    -- * Instance derivation
  , customGeneric
  ) where

import qualified GHC.Generics as G
import Generics.Deriving.TH (makeRep0Inline)
import Language.Haskell.TH

----------------------------------------------------------------------------
-- 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)

-- | Type of a strategy to derive 'G.Generic' instances, it will be given the actual
-- 'CstrShape's for a data-type and needs to return the 'CstrDepth's for it.
-- It should when possible make checks and 'fail', using the constructors' 'Name'
-- provided by the 'CstrShape'.
type GenericStrategy = [CstrShape] -> Q [CstrDepth]

-- | Simple type synonym used (internally) between functions, basically extending
-- 'CstrDepth' with the 'Name's of the constructor and its fields.
type NamedCstrDepths = (Natural, Name, [(Natural, Name)])

----------------------------------------------------------------------------
-- Custom 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 :: [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).
rightBalanced :: GenericStrategy
rightBalanced :: GenericStrategy
rightBalanced = (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy Int -> [Natural]
makeRightBalDepths

-- | Strategy to make left-balanced instances (both in constructors and fields).
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

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

-- | Helper to make a strategy that created depths for constructor and fields
-- in the same way, just from their number.
fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy dStrategy :: Int -> [Natural]
dStrategy 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
. CstrShape -> Int
forall a b. (a, b) -> b
snd) [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]

----------------------------------------------------------------------------
-- 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
----------------------------------------------------------------------------

-- | 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)
-- @@@
--
customGeneric :: String -> GenericStrategy -> Q [Dec]
customGeneric :: String -> GenericStrategy -> Q [Dec]
customGeneric typeStr :: String
typeStr genStrategy :: GenericStrategy
genStrategy = do
  -- reify the data type
  (typeName :: Name
typeName, mKind :: Maybe Kind
mKind, vars :: [TyVarBndr]
vars, constructors :: [Con]
constructors) <- String -> Q (Name, Maybe Kind, [TyVarBndr], [Con])
reifyDataType String
typeStr
  -- obtain info about its constructor and desired tree
  let derivedType :: TypeQ
derivedType = Name -> Maybe Kind -> [TyVarBndr] -> TypeQ
deriveFullType Name
typeName Maybe Kind
mKind [TyVarBndr]
vars
  [CstrShape]
cShapes <- [Con] -> Q [CstrShape]
cstrShapes [Con]
constructors
  [CstrDepth]
treeDepths <- GenericStrategy
genStrategy [CstrShape]
cShapes
  [NamedCstrDepths]
weightedConstrs <- [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs [CstrDepth]
treeDepths [CstrShape]
cShapes
  -- produce the Generic instance
  Dec
res <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Kind] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''G.Generic) TypeQ
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 (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''G.Rep) TypeQ
derivedType) (TypeQ -> DecQ) -> TypeQ -> DecQ
forall a b. (a -> b) -> a -> b
$
        Name -> [CstrDepth] -> TypeQ -> TypeQ
makeUnbalancedRep Name
typeName [CstrDepth]
treeDepths TypeQ
derivedType
    , [NamedCstrDepths] -> DecQ
makeUnbalancedFrom [NamedCstrDepths]
weightedConstrs
    , [NamedCstrDepths] -> DecQ
makeUnbalancedTo [NamedCstrDepths]
weightedConstrs
    ]
  return [Dec
res]

-- | 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 :: String -> Q (Name, Maybe Kind, [TyVarBndr], [Con])
reifyDataType :: String -> Q (Name, Maybe Kind, [TyVarBndr], [Con])
reifyDataType typeStr :: String
typeStr = do
  Info
typeInfo <- String -> Q (Maybe Name)
lookupTypeName String
typeStr Q (Maybe Name) -> (Maybe Name -> Q Info) -> Q Info
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Nothing -> String -> Q Info
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Info) -> String -> Q Info
forall a b. (a -> b) -> a -> b
$ "Failed type name lookup for: '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typeStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "'."
    Just tn :: Name
tn -> Name -> Q Info
reify Name
tn
  case Info
typeInfo of
    TyConI (DataD _ typeName :: Name
typeName vars :: [TyVarBndr]
vars mKind :: Maybe Kind
mKind constrs :: [Con]
constrs _) ->
      (Name, Maybe Kind, [TyVarBndr], [Con])
-> Q (Name, Maybe Kind, [TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typeName, Maybe Kind
mKind, [TyVarBndr]
vars, [Con]
constrs)
    _ -> String -> Q (Name, Maybe Kind, [TyVarBndr], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, Maybe Kind, [TyVarBndr], [Con]))
-> String -> Q (Name, 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
<>
      String
typeStr 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

-- | Calculate the "shape" for each of the given constructors.
-- The shape is simply the 'Name' of the constructor and the number of its args.
cstrShapes :: [Con] -> Q [CstrShape]
cstrShapes :: [Con] -> Q [CstrShape]
cstrShapes constructors :: [Con]
constructors = [Con] -> (Con -> Q CstrShape) -> Q [CstrShape]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Con]
constructors ((Con -> Q CstrShape) -> Q [CstrShape])
-> (Con -> Q CstrShape) -> Q [CstrShape]
forall a b. (a -> b) -> a -> b
$ \case
  NormalC name :: Name
name lst :: [BangType]
lst -> CstrShape -> Q CstrShape
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, [BangType] -> Int
forall t. Container t => t -> Int
length [BangType]
lst)
  RecC name :: Name
name lst :: [VarBangType]
lst    -> CstrShape -> Q CstrShape
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, [VarBangType] -> Int
forall t. Container t => t -> Int
length [VarBangType]
lst)
  InfixC _ name :: Name
name _  -> CstrShape -> Q CstrShape
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, 2)
  constr :: Con
constr           -> String -> Q CstrShape
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q CstrShape) -> String -> Q CstrShape
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 :: [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs :: [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
makeWeightedConstrs treeDepths :: [CstrDepth]
treeDepths cSizes :: [CstrShape]
cSizes = do
  [(CstrDepth, CstrShape)]
-> ((CstrDepth, CstrShape) -> Q NamedCstrDepths)
-> Q [NamedCstrDepths]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([CstrDepth] -> [CstrShape] -> [(CstrDepth, CstrShape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CstrDepth]
treeDepths [CstrShape]
cSizes) (((CstrDepth, CstrShape) -> Q NamedCstrDepths)
 -> Q [NamedCstrDepths])
-> ((CstrDepth, CstrShape) -> Q NamedCstrDepths)
-> Q [NamedCstrDepths]
forall a b. (a -> b) -> a -> b
$ \((cDepth :: Natural
cDepth, fDepths :: [Natural]
fDepths), (cName :: Name
cName, fNum :: Int
fNum)) -> do
    [Name]
constrVarsNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
fNum (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "v"
    return (Natural
cDepth, Name
cName, [Natural] -> [Name] -> [(Natural, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural]
fDepths [Name]
constrVarsNames)

-- | 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] -> TypeQ -> TypeQ
makeUnbalancedRep :: Name -> [CstrDepth] -> TypeQ -> TypeQ
makeUnbalancedRep typeName :: Name
typeName treeDepths :: [CstrDepth]
treeDepths 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 :: [Kind]
constrTypes) <- TypeQ -> TypeQ -> Kind -> Q (Kind, [Kind])
dismantleGenericTree [t| (G.:+:) |] [t| G.C1 |] Kind
balRep
  -- for each of the constructor's trees
  [(Natural, Kind)]
unbalConstrs <- [(Kind, CstrDepth)]
-> ((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 ([Kind] -> [CstrDepth] -> [(Kind, CstrDepth)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Kind]
constrTypes [CstrDepth]
treeDepths) (((Kind, CstrDepth) -> Q (Natural, Kind)) -> Q [(Natural, Kind)])
-> ((Kind, CstrDepth) -> Q (Natural, Kind)) -> Q [(Natural, Kind)]
forall a b. (a -> b) -> a -> b
$ \(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, fields :: [Natural]
fields) -> do
        -- separate the top-most constructor metadata from the fields' trees
        (constrMd :: Kind
constrMd, fieldTypes :: [Kind]
fieldTypes) <- TypeQ -> TypeQ -> Kind -> Q (Kind, [Kind])
dismantleGenericTree [t| (G.:*:) |] [t| G.S1 |] Kind
constrType
        -- build the unbalanced tree of fields
        Kind
unbalConstRes <- [(Natural, Kind)] -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold ([Natural] -> [Kind] -> [(Natural, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural]
fields [Kind]
fieldTypes) (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 -> TypeQ -> Type -> Q (Type, [Type])
dismantleGenericTree :: TypeQ -> TypeQ -> Kind -> Q (Kind, [Kind])
dismantleGenericTree nodeConstrQ :: TypeQ
nodeConstrQ leafMetaQ :: TypeQ
leafMetaQ (AppT meta :: Kind
meta nodes :: Kind
nodes) = do
  Kind
nodeConstr <- TypeQ
nodeConstrQ
  Kind
leafMeta <- TypeQ
leafMetaQ
  let collectLeafsTypes :: Type -> [Type]
      collectLeafsTypes :: Kind -> [Kind]
collectLeafsTypes tp :: Kind
tp@(AppT a :: Kind
a b :: Kind
b) = case Kind
a of
        AppT md :: Kind
md _ | Kind
md Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
leafMeta -> [Kind
tp]
        nd :: Kind
nd | Kind
nd Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
nodeConstr -> Kind -> [Kind]
collectLeafsTypes Kind
b
        _ -> Kind -> [Kind]
collectLeafsTypes Kind
a [Kind] -> [Kind] -> [Kind]
forall a. Semigroup a => a -> a -> a
<> Kind -> [Kind]
collectLeafsTypes Kind
b
      collectLeafsTypes x :: Kind
x = Text -> [Kind]
forall a. HasCallStack => Text -> a
error (Text -> [Kind]) -> Text -> [Kind]
forall a b. (a -> b) -> a -> b
$
        "Unexpected lack of Generic constructor application: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Kind -> Text
forall b a. (Show a, IsString b) => a -> b
show Kind
x
  (Kind, [Kind]) -> Q (Kind, [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
meta, Kind -> [Kind]
collectLeafsTypes Kind
nodes)
dismantleGenericTree _ _ x :: Kind
x = Text -> Q (Kind, [Kind])
forall a. HasCallStack => Text -> a
error (Text -> Q (Kind, [Kind])) -> Text -> Q (Kind, [Kind])
forall a b. (a -> b) -> a -> b
$
  "Unexpected lack of Generic Metadata: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Kind -> Text
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
$ \(cDepth :: Natural
cDepth, cName :: Name
cName, wFields :: [(Natural, Name)]
wFields) -> do
    (fPatts :: [Pat]
fPatts, fDepthExp :: [(Natural, Exp)]
fDepthExp) <- ([(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)]))
-> (((Natural, Name) -> Q (Pat, (Natural, Exp)))
    -> Q [(Pat, (Natural, Exp))])
-> ((Natural, Name) -> Q (Pat, (Natural, Exp)))
-> Q ([Pat], [(Natural, Exp)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Natural, Name)]
-> ((Natural, Name) -> 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 [(Natural, Name)]
wFields (((Natural, Name) -> Q (Pat, (Natural, Exp)))
 -> Q ([Pat], [(Natural, Exp)]))
-> ((Natural, Name) -> Q (Pat, (Natural, Exp)))
-> Q ([Pat], [(Natural, Exp)])
forall a b. (a -> b) -> a -> b
$ \(fDepth :: Natural
fDepth, fName :: Name
fName) -> do
      -- make pattern for field variable
      Pat
fPat <- Name -> PatQ
varP Name
fName
      -- 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 (Pat
fPat, (Natural
fDepth, Exp
fExpr))
    -- make pattern for this constructor
    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 -> [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Pat -> PatQ
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
$ \(cDepth :: Natural
cDepth, cName :: Name
cName, wFields :: [(Natural, Name)]
wFields) -> do
    (fExps :: [Exp]
fExps, fDepthPat :: [(Natural, Pat)]
fDepthPat) <- ([(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)]))
-> (((Natural, Name) -> Q (Exp, (Natural, Pat)))
    -> Q [(Exp, (Natural, Pat))])
-> ((Natural, Name) -> Q (Exp, (Natural, Pat)))
-> Q ([Exp], [(Natural, Pat)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Natural, Name)]
-> ((Natural, Name) -> 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 [(Natural, Name)]
wFields (((Natural, Name) -> Q (Exp, (Natural, Pat)))
 -> Q ([Exp], [(Natural, Pat)]))
-> ((Natural, Name) -> Q (Exp, (Natural, Pat)))
-> Q ([Exp], [(Natural, Pat)])
forall a b. (a -> b) -> a -> b
$ \(fDepth :: Natural
fDepth, fName :: Name
fName) -> do
      -- make expression for field variable
      Exp
fExp <- Name -> ExpQ
varE Name
fName
      -- make pattern for a Generic Field from its variable
      Pat
fPatt <- Name -> PatQ -> PatQ
conP1 'G.M1 (PatQ -> PatQ) -> (PatQ -> PatQ) -> PatQ -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PatQ -> PatQ
conP1 'G.K1 (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
varP Name
fName
      return (Exp
fExp, (Natural
fDepth, Pat
fPatt))
    -- make pattern for this isolated Generic Constructor
    Pat
cPatt <- Name -> PatQ -> PatQ
conP1 'G.M1 (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ case [(Natural, Pat)]
fDepthPat of
      [] -> Name -> [PatQ] -> PatQ
conP 'G.U1 []
      _  -> [(Natural, Pat)] -> (PatQ -> PatQ -> PatQ) -> PatQ
forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a
unbalancedFold [(Natural, Pat)]
fDepthPat (Name -> PatQ -> PatQ -> PatQ
conP2 '(G.:*:))
    -- make expression to assemble this constructor
    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
    (Exp, (Natural, [Pat])) -> Q (Exp, (Natural, [Pat]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
cExp, (Natural
cDepth, [Pat
cPatt]))
  -- make patterns for all Generic Constructors
  [Pat]
cPatts <- (PatQ -> PatQ) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> PatQ -> PatQ
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
<$> (PatQ -> PatQ) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> PatQ -> PatQ
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
<*> (PatQ -> PatQ) -> Q [Pat] -> Q [Pat]
forall a. (Q a -> Q a) -> Q [a] -> Q [a]
mapQ (Name -> PatQ -> PatQ
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 -> [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Pat -> PatQ
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 -> PatQ -> PatQ
conP1 name :: Name
name pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
name [PatQ
pat]

conP2 :: Name -> PatQ -> PatQ -> PatQ
conP2 :: Name -> PatQ -> PatQ -> PatQ
conP2 name :: Name
name pat1 :: PatQ
pat1 pat2 :: PatQ
pat2 = Name -> [PatQ] -> PatQ
conP Name
name [PatQ
pat1, PatQ
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)