------------------------------------------------------------------------
-- |
-- Module           : Data.Parameterized.TH.GADT
-- Copyright        : (c) Galois, Inc 2013-2019
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Description : Template Haskell primitives for working with large GADTs
--
-- This module declares template Haskell primitives so that it is easier
-- to work with GADTs that have many constructors.
------------------------------------------------------------------------
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE EmptyCase #-}
module Data.Parameterized.TH.GADT
  ( -- * Instance generators
    -- $typePatterns
  structuralEquality
  , structuralTypeEquality
  , structuralTypeOrd
  , structuralTraversal
  , structuralShowsPrec
  , structuralHash
  , structuralHashWithSalt
  , PolyEq(..)
    -- * Template haskell utilities that may be useful in other contexts.
  , DataD
  , lookupDataType'
  , asTypeCon
  , conPat
  , TypePat(..)
  , dataParamTypes
  , assocTypePats
  ) where

import Control.Monad
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Language.Haskell.TH
import Language.Haskell.TH.Datatype


import Data.Parameterized.Classes

------------------------------------------------------------------------
-- Template Haskell utilities

type DataD = DatatypeInfo

lookupDataType' :: Name -> Q DatatypeInfo
lookupDataType' :: Name -> Q DatatypeInfo
lookupDataType' = Name -> Q DatatypeInfo
reifyDatatype

-- | Given a constructor and string, this generates a pattern for matching
-- the expression, and the names of variables bound by pattern in order
-- they appear in constructor.
conPat ::
  ConstructorInfo {- ^ constructor information -} ->
  String          {- ^ generated name prefix   -} ->
  Q (Pat, [Name]) {- ^ pattern and bound names -}
conPat :: ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
pre = do
  [Name]
nms <- String -> Int -> Q [Name]
newNames String
pre ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con))
  (Pat, [Name]) -> Q (Pat, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
ConP (ConstructorInfo -> Name
constructorName ConstructorInfo
con) (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
nms), [Name]
nms)


-- | Return an expression corresponding to the constructor.
-- Note that this will have the type of a function expecting
-- the argumetns given.
conExpr :: ConstructorInfo -> Exp
conExpr :: ConstructorInfo -> Exp
conExpr = Name -> Exp
ConE (Name -> Exp)
-> (ConstructorInfo -> Name) -> ConstructorInfo -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName

------------------------------------------------------------------------
-- TypePat

-- | A type used to describe (and match) types appearing in generated pattern
-- matches inside of the TH generators in this module ('structuralEquality',
-- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal')
data TypePat
   = TypeApp TypePat TypePat -- ^ The application of a type.
   | AnyType       -- ^ Match any type.
   | DataArg Int   -- ^ Match the i'th argument of the data type we are traversing.
   | ConType TypeQ -- ^ Match a ground type.

matchTypePat :: [Type] -> TypePat -> Type -> Q Bool
matchTypePat :: [Type] -> TypePat -> Type -> Q Bool
matchTypePat [Type]
d (TypeApp TypePat
p TypePat
q) (AppT Type
x Type
y) = do
  Bool
r <- [Type] -> TypePat -> Type -> Q Bool
matchTypePat [Type]
d TypePat
p Type
x
  case Bool
r of
    Bool
True -> [Type] -> TypePat -> Type -> Q Bool
matchTypePat [Type]
d TypePat
q Type
y
    Bool
False -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
matchTypePat [Type]
_ TypePat
AnyType Type
_ = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
matchTypePat [Type]
tps (DataArg Int
i) Type
tp
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tps = String -> Q Bool
forall a. HasCallStack => String -> a
error (String
"Type pattern index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" out of bounds")
  | Bool
otherwise = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
stripSigT ([Type]
tps [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
i) Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tp)
  where
    -- th-abstraction can annotate type parameters with their kinds,
    -- we ignore these for matching
    stripSigT :: Type -> Type
stripSigT (SigT Type
t Type
_) = Type
t
    stripSigT Type
t          = Type
t
matchTypePat [Type]
_ (ConType TypeQ
tpq) Type
tp = do
  Type
tp' <- TypeQ
tpq
  Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
tp' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tp)
matchTypePat [Type]
_ TypePat
_ Type
_ = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | The dataParamTypes function returns the list of Type arguments
-- for the constructor.  For example, if passed the DatatypeInfo for a
-- @newtype Id a = MkId a@ then this would return @['SigT' ('VarT' a)
-- 'StarT']@.  Note that there may be type *variables* not referenced
-- in the returned array; this simply returns the type *arguments*.
dataParamTypes :: DatatypeInfo -> [Type]
dataParamTypes :: DatatypeInfo -> [Type]
dataParamTypes = DatatypeInfo -> [Type]
datatypeInstTypes
 -- see th-abstraction 'dataTypeVars' for the type variables if needed

-- | Find value associated with first pattern that matches given pat if any.
assocTypePats :: [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats :: [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
_ [] Type
_ = Maybe v -> Q (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
assocTypePats [Type]
dTypes ((TypePat
p,v
v):[(TypePat, v)]
pats) Type
tp = do
  Bool
r <- [Type] -> TypePat -> Type -> Q Bool
matchTypePat [Type]
dTypes TypePat
p Type
tp
  case Bool
r of
    Bool
True -> Maybe v -> Q (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Maybe v
forall a. a -> Maybe a
Just v
v)
    Bool
False -> [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
dTypes [(TypePat, v)]
pats Type
tp

------------------------------------------------------------------------
-- Contructor cases

typeVars :: TypeSubstitution a => a -> Set Name
typeVars :: a -> Set Name
typeVars = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> (a -> [Name]) -> a -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables


-- | @structuralEquality@ declares a structural equality predicate.
structuralEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ
structuralEquality :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralEquality TypeQ
tpq [(TypePat, ExpQ)]
pats =
  [| \x y -> isJust ($(structuralTypeEquality tpq pats) x y) |]

joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ
joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ
joinEqMaybe Name
x Name
y ExpQ
r = do
  [| if $(varE x) == $(varE y) then $(r) else Nothing |]

joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinTestEquality ExpQ
f Name
x Name
y ExpQ
r =
  [| case $(f) $(varE x) $(varE y) of
      Nothing -> Nothing
      Just Refl -> $(r)
   |]

matchEqArguments :: [Type]
                    -- ^ Types bound by data arguments.
                 -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                 -> Name
                     -- ^ Name of constructor.
                 -> Set Name
                 -> [Type]
                 -> [Name]
                 -> [Name]
                 -> ExpQ
matchEqArguments :: [Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchEqArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd (Type
tp:[Type]
tpl) (Name
x:[Name]
xl) (Name
y:[Name]
yl) = do
  Maybe ExpQ
doesMatch <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
dTypes [(TypePat, ExpQ)]
pats Type
tp
  case Maybe ExpQ
doesMatch of
    Just ExpQ
q -> do
      let bnd' :: Set Name
bnd' =
            case Type
tp of
              AppT Type
_ (VarT Name
nm) -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
nm Set Name
bnd
              Type
_ -> Set Name
bnd
      ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinTestEquality ExpQ
q Name
x Name
y ([Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchEqArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd' [Type]
tpl [Name]
xl [Name]
yl)
    Maybe ExpQ
Nothing | Type -> Set Name
forall a. TypeSubstitution a => a -> Set Name
typeVars Type
tp Set Name -> Set Name -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Name
bnd -> do
      Name -> Name -> ExpQ -> ExpQ
joinEqMaybe Name
x Name
y        ([Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchEqArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd  [Type]
tpl [Name]
xl [Name]
yl)
    Maybe ExpQ
Nothing -> do
      String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Unsupported argument type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
tp
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
cnm) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [] [] = [| Just Refl |]
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [Name]
_  [Name]
_  = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of types."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [] [Name]
_  = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of names."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [Name]
_  [] = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of names."

mkSimpleEqF :: [Type] -- ^ Data declaration types
            -> Set Name
             -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
             -> ConstructorInfo
             -> [Name]
             -> ExpQ
             -> Bool -- ^ wildcard case required
             -> ExpQ
mkSimpleEqF :: [Type]
-> Set Name
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> [Name]
-> ExpQ
-> Bool
-> ExpQ
mkSimpleEqF [Type]
dTypes Set Name
bnd [(TypePat, ExpQ)]
pats ConstructorInfo
con [Name]
xv ExpQ
yQ Bool
multipleCases = do
  -- Get argument types for constructor.
  let nm :: Name
nm = ConstructorInfo -> Name
constructorName ConstructorInfo
con
  (Pat
yp,[Name]
yv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"y"
  let rv :: ExpQ
rv = [Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchEqArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
nm Set Name
bnd (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con) [Name]
xv [Name]
yv
  ExpQ -> [MatchQ] -> ExpQ
caseE ExpQ
yQ ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
yp) (ExpQ -> BodyQ
normalB ExpQ
rv) []
           MatchQ -> [MatchQ] -> [MatchQ]
forall a. a -> [a] -> [a]
: [ PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB [| Nothing |]) [] | Bool
multipleCases ]

-- | Match equational form.
mkEqF :: DatatypeInfo -- ^ Data declaration.
      -> [(TypePat,ExpQ)]
      -> ConstructorInfo
      -> [Name]
      -> ExpQ
      -> Bool -- ^ wildcard case required
      -> ExpQ
mkEqF :: DatatypeInfo
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> [Name]
-> ExpQ
-> Bool
-> ExpQ
mkEqF DatatypeInfo
d [(TypePat, ExpQ)]
pats ConstructorInfo
con =
  let dVars :: [Type]
dVars = DatatypeInfo -> [Type]
dataParamTypes DatatypeInfo
d  -- the type arguments for the constructor
      -- bnd is the list of type arguments for this datatype.  Since
      -- this is Functor equality, ignore the final type since this is
      -- a higher-kinded equality.
      bnd :: Set Name
bnd | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
dVars = Set Name
forall a. Set a
Set.empty
          | Bool
otherwise  = [Type] -> Set Name
forall a. TypeSubstitution a => a -> Set Name
typeVars ([Type] -> [Type]
forall a. [a] -> [a]
init [Type]
dVars)
  in [Type]
-> Set Name
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> [Name]
-> ExpQ
-> Bool
-> ExpQ
mkSimpleEqF [Type]
dVars Set Name
bnd [(TypePat, ExpQ)]
pats ConstructorInfo
con

-- | @structuralTypeEquality f@ returns a function with the type:
--   @
--     forall x y . f x -> f y -> Maybe (x :~: y)
--   @
structuralTypeEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ
structuralTypeEquality :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralTypeEquality TypeQ
tpq [(TypePat, ExpQ)]
pats = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTypeEquality" (Type -> Q Name) -> TypeQ -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq

  let multipleCons :: Bool
multipleCons = Bool -> Bool
not ([ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> [ConstructorInfo] -> [ConstructorInfo]
forall a. Int -> [a] -> [a]
drop Int
1 (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)))
      trueEqs :: ExpQ -> [MatchQ]
trueEqs ExpQ
yQ = [ do (Pat
xp,[Name]
xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"x"
                        PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
xp) (ExpQ -> BodyQ
normalB (DatatypeInfo
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> [Name]
-> ExpQ
-> Bool
-> ExpQ
mkEqF DatatypeInfo
d [(TypePat, ExpQ)]
pats ConstructorInfo
con [Name]
xv ExpQ
yQ Bool
multipleCons)) []
                   | ConstructorInfo
con <- DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d
                   ]

  if [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)
    then [| \x -> case x of {} |]
    else [| \x y -> $(caseE [| x |] (trueEqs [| y |])) |]

-- | @structuralTypeOrd f@ returns a function with the type:
--   @
--     forall x y . f x -> f y -> OrderingF x y
--   @
--
-- This implementation avoids matching on both the first and second
-- parameters in a simple case expression in order to avoid stressing
-- GHC's coverage checker. In the case that the first and second parameters
-- have unique constructors, a simple numeric comparison is done to
-- compute the result.
structuralTypeOrd ::
  TypeQ ->
  [(TypePat,ExpQ)] {- ^ List of type patterns to match. -} ->
  ExpQ
structuralTypeOrd :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralTypeOrd TypeQ
tpq [(TypePat, ExpQ)]
l = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTypeEquality" (Type -> Q Name) -> TypeQ -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq

  let withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ
      withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ
withNumber ExpQ
yQ Maybe ExpQ -> ExpQ
k
        | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> [ConstructorInfo] -> [ConstructorInfo]
forall a. Int -> [a] -> [a]
drop Int
1 (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)) = Maybe ExpQ -> ExpQ
k Maybe ExpQ
forall a. Maybe a
Nothing
        | Bool
otherwise =  [| let yn :: Int
                              yn = $(caseE yQ (constructorNumberMatches (datatypeCons d)))
                          in $(k (Just [| yn |])) |]

  if [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)
    then [| \x -> case x of {} |]
    else [| \x y -> $(withNumber [|y|] $ \mbYn -> caseE [| x |] (outerOrdMatches d [|y|] mbYn)) |]
  where
    constructorNumberMatches :: [ConstructorInfo] -> [MatchQ]
    constructorNumberMatches :: [ConstructorInfo] -> [MatchQ]
constructorNumberMatches [ConstructorInfo]
cons =
      [ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [FieldPatQ] -> PatQ
recP (ConstructorInfo -> Name
constructorName ConstructorInfo
con) [])
              (ExpQ -> BodyQ
normalB (Lit -> ExpQ
litE (Integer -> Lit
integerL Integer
i)))
              []
      | (Integer
i,ConstructorInfo
con) <- [Integer] -> [ConstructorInfo] -> [(Integer, ConstructorInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [ConstructorInfo]
cons ]

    outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ]
    outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ]
outerOrdMatches DatatypeInfo
d ExpQ
yExp Maybe ExpQ
mbYn =
      [ do (Pat
pat,[Name]
xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"x"
           PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat)
                 (ExpQ -> BodyQ
normalB (do [MatchQ]
xs <- DatatypeInfo
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [MatchQ]
mkOrdF DatatypeInfo
d [(TypePat, ExpQ)]
l ConstructorInfo
con Integer
i Maybe ExpQ
mbYn [Name]
xv
                              ExpQ -> [MatchQ] -> ExpQ
caseE ExpQ
yExp [MatchQ]
xs))
                 []
      | (Integer
i,ConstructorInfo
con) <- [Integer] -> [ConstructorInfo] -> [(Integer, ConstructorInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d) ]

-- | Generate a list of fresh names using the base name
-- and numbered 1 to @n@ to make them useful in conjunction with
-- @-dsuppress-uniques@.
newNames ::
  String   {- ^ base name                     -} ->
  Int      {- ^ quantity                      -} ->
  Q [Name] {- ^ list of names: @base1@, @base2@, ... -}
newNames :: String -> Int -> Q [Name]
newNames String
base Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Int
i -> String -> Q Name
newName (String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)) [Int
1..Int
n]


joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinCompareF ExpQ
f Name
x Name
y ExpQ
r = do
  [| case $(f) $(varE x) $(varE y) of
      LTF -> LTF
      GTF -> GTF
      EQF -> $(r)
   |]

-- | Compare two variables, returning the third argument if they are equal.
--
-- This returns an 'OrdF' instance.
joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ
joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ
joinCompareToOrdF Name
x Name
y ExpQ
r =
  [| case compare $(varE x) $(varE y) of
      LT -> LTF
      GT -> GTF
      EQ -> $(r)
   |]

-- | Match expression with given type to variables
matchOrdArguments :: [Type]
                     -- ^ Types bound by data arguments
                  -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                  -> Name
                     -- ^ Name of constructor.
                  -> Set Name
                    -- ^ Names bound in data declaration
                  -> [Type]
                     -- ^ Types for constructors
                  -> [Name]
                     -- ^ Variables bound in first pattern
                  -> [Name]
                     -- ^ Variables bound in second pattern
                  -> ExpQ
matchOrdArguments :: [Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchOrdArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd (Type
tp : [Type]
tpl) (Name
x:[Name]
xl) (Name
y:[Name]
yl) = do
  Maybe ExpQ
doesMatch <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
dTypes [(TypePat, ExpQ)]
pats Type
tp
  case Maybe ExpQ
doesMatch of
    Just ExpQ
f -> do
      let bnd' :: Set Name
bnd' = case Type
tp of
                   AppT Type
_ (VarT Name
nm) -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
nm Set Name
bnd
                   Type
_ -> Set Name
bnd
      ExpQ -> Name -> Name -> ExpQ -> ExpQ
joinCompareF ExpQ
f Name
x Name
y ([Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchOrdArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd' [Type]
tpl [Name]
xl [Name]
yl)
    Maybe ExpQ
Nothing | Type -> Set Name
forall a. TypeSubstitution a => a -> Set Name
typeVars Type
tp Set Name -> Set Name -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Name
bnd -> do
      Name -> Name -> ExpQ -> ExpQ
joinCompareToOrdF Name
x Name
y ([Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchOrdArguments [Type]
dTypes [(TypePat, ExpQ)]
pats Name
cnm Set Name
bnd [Type]
tpl [Name]
xl [Name]
yl)
    Maybe ExpQ
Nothing ->
      String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Unsupported argument type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
tp)
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
cnm) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [] [] = [| EQF |]
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [Name]
_  [Name]
_  = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of types."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [] [Name]
_  = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of names."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [Name]
_  [] = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpected end of names."

mkSimpleOrdF :: [Type] -- ^ Data declaration types
             -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
             -> ConstructorInfo -- ^ Information about the second constructor
             -> Integer -- ^ First constructor's index
             -> Maybe ExpQ -- ^ Optional second constructor's index
             -> [Name]  -- ^ Name from first pattern
             -> Q [MatchQ]
mkSimpleOrdF :: [Type]
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [MatchQ]
mkSimpleOrdF [Type]
dTypes [(TypePat, ExpQ)]
pats ConstructorInfo
con Integer
xnum Maybe ExpQ
mbYn [Name]
xv = do
  (Pat
yp,[Name]
yv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"y"
  let rv :: ExpQ
rv = [Type]
-> [(TypePat, ExpQ)]
-> Name
-> Set Name
-> [Type]
-> [Name]
-> [Name]
-> ExpQ
matchOrdArguments [Type]
dTypes [(TypePat, ExpQ)]
pats (ConstructorInfo -> Name
constructorName ConstructorInfo
con) Set Name
forall a. Set a
Set.empty (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con) [Name]
xv [Name]
yv
  -- Return match expression
  [MatchQ] -> Q [MatchQ]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MatchQ] -> Q [MatchQ]) -> [MatchQ] -> Q [MatchQ]
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
yp) (ExpQ -> BodyQ
normalB ExpQ
rv) []
         MatchQ -> [MatchQ] -> [MatchQ]
forall a. a -> [a] -> [a]
: case Maybe ExpQ
mbYn of
             Maybe ExpQ
Nothing -> []
             Just ExpQ
yn -> [PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB [| if xnum < $yn then LTF else GTF |]) []]

-- | Match equational form.
mkOrdF :: DatatypeInfo -- ^ Data declaration.
       -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
       -> ConstructorInfo
       -> Integer
       -> Maybe ExpQ -- ^ optional right constructr index
       -> [Name]
       -> Q [MatchQ]
mkOrdF :: DatatypeInfo
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [MatchQ]
mkOrdF DatatypeInfo
d [(TypePat, ExpQ)]
pats = [Type]
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [MatchQ]
mkSimpleOrdF (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
d) [(TypePat, ExpQ)]
pats

-- | @genTraverseOfType f var tp@ applies @f@ to @var@ where @var@ has type @tp@.
genTraverseOfType :: [Type]
                    -- ^ Argument types for the data declaration.
                 -> [(TypePat, ExpQ)]
                    -- ^ Patterrns the user provided for overriding type lookup.
                  -> ExpQ -- ^ Function to apply
                  -> ExpQ -- ^ Expression denoting value of this constructor field.
                  -> Type -- ^ Type bound for this constructor field.
                  -> Q (Maybe Exp)
genTraverseOfType :: [Type]
-> [(TypePat, ExpQ)] -> ExpQ -> ExpQ -> Type -> Q (Maybe Exp)
genTraverseOfType [Type]
dataArgs [(TypePat, ExpQ)]
pats ExpQ
f ExpQ
v Type
tp = do
  Maybe ExpQ
mr <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
dataArgs [(TypePat, ExpQ)]
pats Type
tp
  case Maybe ExpQ
mr of
    Just ExpQ
g ->  Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(g) $(f) $(v) |]
    Maybe ExpQ
Nothing ->
      case Type
tp of
        AppT (ConT Name
_) (AppT (VarT Name
_) Type
_) -> Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| traverse $(f) $(v) |]
        AppT (VarT Name
_) Type
_ -> Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(f) $(v) |]
        Type
_ -> Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing

-- | @traverseAppMatch patMatch cexp @ builds a case statement that matches a term with
-- the constructor @c@ and applies @f@ to each argument.
traverseAppMatch :: [Type]
                    -- ^ Argument types for the data declaration.
                 -> [(TypePat, ExpQ)]
                    -- ^ Patterrns the user provided for overriding type lookup.
                 -> ExpQ -- ^ Function @f@ given to `traverse`
                 -> ConstructorInfo -- ^ Constructor to match.
                 -> MatchQ
traverseAppMatch :: [Type] -> [(TypePat, ExpQ)] -> ExpQ -> ConstructorInfo -> MatchQ
traverseAppMatch [Type]
dataArgs [(TypePat, ExpQ)]
pats ExpQ
fv ConstructorInfo
c0 = do
  (Pat
pat,[Name]
patArgs) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
c0 String
"p"
  [Maybe Exp]
exprs <- (ExpQ -> Type -> Q (Maybe Exp))
-> [ExpQ] -> [Type] -> Q [Maybe Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ([Type]
-> [(TypePat, ExpQ)] -> ExpQ -> ExpQ -> Type -> Q (Maybe Exp)
genTraverseOfType [Type]
dataArgs [(TypePat, ExpQ)]
pats ExpQ
fv) (Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
patArgs) (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
c0)
  let mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ
      mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ
mkRes ExpQ
e [] = ExpQ
e
      mkRes ExpQ
e ((Name
v,Maybe Exp
Nothing):[(Name, Maybe Exp)]
r) =
        ExpQ -> [(Name, Maybe Exp)] -> ExpQ
mkRes (ExpQ -> ExpQ -> ExpQ
appE ExpQ
e (Name -> ExpQ
varE Name
v)) [(Name, Maybe Exp)]
r
      mkRes ExpQ
e ((Name
_,Just{}):[(Name, Maybe Exp)]
r) = do
        Name
v <- String -> Q Name
newName String
"r"
        [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
v] (ExpQ -> [(Name, Maybe Exp)] -> ExpQ
mkRes (ExpQ -> ExpQ -> ExpQ
appE ExpQ
e (Name -> ExpQ
varE Name
v)) [(Name, Maybe Exp)]
r)

  -- Apply the remaining argument to the expression in list.
  let applyRest :: ExpQ -> [Exp] -> ExpQ
      applyRest :: ExpQ -> [Exp] -> ExpQ
applyRest ExpQ
e [] = ExpQ
e
      applyRest ExpQ
e (Exp
a:[Exp]
r) = ExpQ -> [Exp] -> ExpQ
applyRest [| $(e) <*> $(pure a) |] [Exp]
r

  -- Apply the first argument to the list
  let applyFirst :: ExpQ -> [Exp] -> ExpQ
      applyFirst :: ExpQ -> [Exp] -> ExpQ
applyFirst ExpQ
e [] = [| pure $(e) |]
      applyFirst ExpQ
e (Exp
a:[Exp]
r) = ExpQ -> [Exp] -> ExpQ
applyRest [| $(e) <$> $(pure a) |] [Exp]
r

  let pargs :: [(Name, Maybe Exp)]
pargs = [Name]
patArgs [Name] -> [Maybe Exp] -> [(Name, Maybe Exp)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Maybe Exp]
exprs
  let rhs :: ExpQ
rhs = ExpQ -> [Exp] -> ExpQ
applyFirst (ExpQ -> [(Name, Maybe Exp)] -> ExpQ
mkRes (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo -> Exp
conExpr ConstructorInfo
c0)) [(Name, Maybe Exp)]
pargs) ([Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
exprs)
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (ExpQ -> BodyQ
normalB ExpQ
rhs) []

-- | @structuralTraversal tp@ generates a function that applies
-- a traversal @f@ to the subterms with free variables in @tp@.
structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralTraversal TypeQ
tpq [(TypePat, ExpQ)]
pats0 = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTraversal" (Type -> Q Name) -> TypeQ -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
f <- String -> Q Name
newName String
"f"
  Name
a <- String -> Q Name
newName String
"a"
  [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
a] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
      ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
a)
      ([Type] -> [(TypePat, ExpQ)] -> ExpQ -> ConstructorInfo -> MatchQ
traverseAppMatch (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
d) [(TypePat, ExpQ)]
pats0 (Name -> ExpQ
varE Name
f) (ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)

asTypeCon :: String -> Type -> Q Name
asTypeCon :: String -> Type -> Q Name
asTypeCon String
_ (ConT Name
nm) = Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
asTypeCon String
fn Type
_ = String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected type constructor.")

-- | @structuralHash tp@ generates a function with the type
-- @Int -> tp -> Int@ that hashes type.
--
-- All arguments use `hashable`, and `structuralHashWithSalt` can be
-- used instead as it allows user-definable patterns to be used at
-- specific types.
structuralHash :: TypeQ -> ExpQ
structuralHash :: TypeQ -> ExpQ
structuralHash TypeQ
tpq = TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralHashWithSalt TypeQ
tpq []
{-# DEPRECATED structuralHash "Use structuralHashWithSalt" #-}

-- | @structuralHashWithSalt tp@ generates a function with the type
-- @Int -> tp -> Int@ that hashes type.
--
-- The second arguments is for generating user-defined patterns to replace
-- `hashWithSalt` for specific types.
structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
structuralHashWithSalt TypeQ
tpq [(TypePat, ExpQ)]
pats = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralHash" (Type -> Q Name) -> TypeQ -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
s <- String -> Q Name
newName String
"s"
  Name
a <- String -> Q Name
newName String
"a"
  [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
s, Name -> PatQ
varP Name
a] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
    ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
a) ((Integer -> ConstructorInfo -> MatchQ)
-> [Integer] -> [ConstructorInfo] -> [MatchQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DatatypeInfo
-> [(TypePat, ExpQ)]
-> ExpQ
-> Integer
-> ConstructorInfo
-> MatchQ
matchHashCtor DatatypeInfo
d [(TypePat, ExpQ)]
pats (Name -> ExpQ
varE Name
s)) [Integer
0..] (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d))

-- | This matches one of the constructors in a datatype when generating
-- a `hashWithSalt` function.
matchHashCtor :: DatatypeInfo
                 -- ^ Data declaration of type we are hashing.
              -> [(TypePat, ExpQ)]
                 -- ^ User provide type patterns
              -> ExpQ -- ^ Initial salt expression
              -> Integer -- ^ Index of constructor
              -> ConstructorInfo -- ^ Constructor information
              -> MatchQ
matchHashCtor :: DatatypeInfo
-> [(TypePat, ExpQ)]
-> ExpQ
-> Integer
-> ConstructorInfo
-> MatchQ
matchHashCtor DatatypeInfo
d [(TypePat, ExpQ)]
pats ExpQ
s0 Integer
i ConstructorInfo
c = do
  (Pat
pat,[Name]
vars) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
c String
"x"
  let go :: ExpQ -> (ExpQ, Type) -> ExpQ
go ExpQ
s (ExpQ
e, Type
tp) = do
        Maybe ExpQ
mr <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
d) [(TypePat, ExpQ)]
pats Type
tp
        case Maybe ExpQ
mr of
          Just ExpQ
f -> do
            [| $(f) $(s) $(e) |]
          Maybe ExpQ
Nothing ->
            [| hashWithSalt $(s) $(e) |]
  let s1 :: ExpQ
s1 = [| hashWithSalt $(s0) ($(litE (IntegerL i)) :: Int) |]
  let rhs :: ExpQ
rhs = (ExpQ -> (ExpQ, Type) -> ExpQ) -> ExpQ -> [(ExpQ, Type)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> (ExpQ, Type) -> ExpQ
go ExpQ
s1 ([ExpQ] -> [Type] -> [(ExpQ, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
c))
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (ExpQ -> BodyQ
normalB ExpQ
rhs) []

-- | @structuralShow tp@ generates a function with the type
-- @tp -> ShowS@ that shows the constructor.
structuralShowsPrec :: TypeQ -> ExpQ
structuralShowsPrec :: TypeQ -> ExpQ
structuralShowsPrec TypeQ
tpq = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralShowPrec" (Type -> Q Name) -> TypeQ -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
p <- String -> Q Name
newName String
"_p"
  Name
a <- String -> Q Name
newName String
"a"
  [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
p, Name -> PatQ
varP Name
a] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
    ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
a) (ExpQ -> ConstructorInfo -> MatchQ
matchShowCtor (Name -> ExpQ
varE Name
p) (ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)

showCon :: ExpQ -> Name -> Int -> MatchQ
showCon :: ExpQ -> Name -> Int -> MatchQ
showCon ExpQ
p Name
nm Int
n = do
  [Name]
vars <- String -> Int -> Q [Name]
newNames String
"x" Int
n
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
nm (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars)
  let go :: ExpQ -> Name -> ExpQ
go ExpQ
s Name
e = [| $(s) . showChar ' ' . showsPrec 11 $(varE e) |]
  let ctor :: ExpQ
ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |]
  let rhs :: ExpQ
rhs | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vars = ExpQ
ctor
          | Bool
otherwise = [| showParen ($(p) >= 11) $(foldl go ctor vars) |]
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (ExpQ -> BodyQ
normalB ExpQ
rhs) []

matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ
matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ
matchShowCtor ExpQ
p ConstructorInfo
con = ExpQ -> Name -> Int -> MatchQ
showCon ExpQ
p (ConstructorInfo -> Name
constructorName ConstructorInfo
con) ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con))

-- $typePatterns
--
-- The Template Haskell instance generators 'structuralEquality',
-- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal'
-- employ heuristics to generate valid instances in the majority of cases.  Most
-- failures in the heuristics occur on sub-terms that are type indexed.  To
-- handle cases where these functions fail to produce a valid instance, they
-- take a list of exceptions in the form of their second parameter, which has
-- type @[('TypePat', 'ExpQ')]@.  Each 'TypePat' is a /matcher/ that tells the
-- TH generator to use the 'ExpQ' to process the matched sub-term.  Consider the
-- following example:
--
-- > data T a b where
-- >   C1 :: NatRepr n -> T () n
-- >
-- > instance TestEquality (T a) where
-- >   testEquality = $(structuralTypeEquality [t|T|]
-- >                    [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|])
-- >                    ])
--
-- The exception list says that 'structuralTypeEquality' should use
-- 'testEquality' to compare any sub-terms of type @'NatRepr' n@ in a value of
-- type @T@.
--
-- * 'AnyType' means that the type parameter in that position can be instantiated as any type
--
-- * @'DataArg' n@ means that the type parameter in that position is the @n@-th
--   type parameter of the GADT being traversed (@T@ in the example)
--
-- * 'TypeApp' is type application
--
-- * 'ConType' specifies a base type
--
-- The exception list could have equivalently (and more precisely) have been specified as:
--
-- > [(ConType [t|NatRepr|] `TypeApp` DataArg 1, [|testEquality|])]
--
-- The use of 'DataArg' says that the type parameter of the 'NatRepr' must
-- be the same as the second type parameter of @T@.