------------------------------------------------------------------------
-- |
-- 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 CPP #-}
{-# 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(..)
    -- * Repr generators (\"singletons\")
    -- $reprs
  , mkRepr
  , mkKnownReprs
    -- * 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con))
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conPCompat (ConstructorInfo -> Name
constructorName ConstructorInfo
con) (Name -> Pat
VarP 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
matchTypePat [Type]
_ TypePat
AnyType Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
matchTypePat [Type]
tps (DataArg Int
i) Type
tp
  | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tps = forall a. HasCallStack => String -> a
error (String
"Type pattern index " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
" out of bounds")
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
stripSigT ([Type]
tps forall a. [a] -> Int -> a
!! Int
i) 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
  forall (m :: * -> *) a. Monad m => a -> m a
return (Type
tp' forall a. Eq a => a -> a -> Bool
== Type
tp)
matchTypePat [Type]
_ TypePat
_ Type
_ = 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 :: forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
assocTypePats [Type]
_ [] Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just v
v)
    Bool
False -> 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 :: forall a. TypeSubstitution a => a -> Set Name
typeVars = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- 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) -> 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 | forall a. TypeSubstitution a => a -> Set Name
typeVars Type
tp 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
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unsupported argument type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
tp
          forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ppr a => a -> Doc
ppr Name
cnm) forall a. [a] -> [a] -> [a]
++ String
"."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [] [] = [| Just Refl |]
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [Name]
_  [Name]
_  = forall a. HasCallStack => String -> a
error String
"Unexpected end of types."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [] [Name]
_  = forall a. HasCallStack => String -> a
error String
"Unexpected end of names."
matchEqArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [Name]
_  [] = 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
  forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE ExpQ
yQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
yp) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
rv) []
           forall a. a -> [a] -> [a]
: [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
dVars = forall a. Set a
Set.empty
          | Bool
otherwise  = forall a. TypeSubstitution a => a -> Set Name
typeVars (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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTypeEquality" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq

  let multipleCons :: Bool
multipleCons = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> [a] -> [a]
drop Int
1 (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)))
      trueEqs :: ExpQ -> [Q Match]
trueEqs ExpQ
yQ = [ do (Pat
xp,[Name]
xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"x"
                        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
xp) (forall (m :: * -> *). Quote m => m Exp -> m Body
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 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTypeEquality" 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
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> [a] -> [a]
drop Int
1 (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d)) = Maybe ExpQ -> ExpQ
k forall a. Maybe a
Nothing
        | Bool
otherwise =  [| let yn :: Int
                              yn = $(caseE yQ (constructorNumberMatches (datatypeCons d)))
                          in $(k (Just [| yn |])) |]

  if 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] -> [Q Match]
constructorNumberMatches [ConstructorInfo]
cons =
      [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP (ConstructorInfo -> Name
constructorName ConstructorInfo
con) [])
              (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL Integer
i)))
              []
      | (Integer
i,ConstructorInfo
con) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [ConstructorInfo]
cons ]

    outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ]
    outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [Q Match]
outerOrdMatches DatatypeInfo
d ExpQ
yExp Maybe ExpQ
mbYn =
      [ do (Pat
pat,[Name]
xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
conPat ConstructorInfo
con String
"x"
           forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat)
                 (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (do [Q Match]
xs <- DatatypeInfo
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [Q Match]
mkOrdF DatatypeInfo
d [(TypePat, ExpQ)]
l ConstructorInfo
con Integer
i Maybe ExpQ
mbYn [Name]
xv
                              forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE ExpQ
yExp [Q Match]
xs))
                 []
      | (Integer
i,ConstructorInfo
con) <- 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Int
i -> forall (m :: * -> *). Quote m => String -> m Name
newName (String
base forall a. [a] -> [a] -> [a]
++ 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 <- 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) -> 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 | forall a. TypeSubstitution a => a -> Set Name
typeVars Type
tp 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 ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unsupported argument type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ppr a => a -> Doc
ppr Type
tp)
             forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ppr a => a -> Doc
ppr Name
cnm) forall a. [a] -> [a] -> [a]
++ String
"."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [] [] = [| EQF |]
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [] [Name]
_  [Name]
_  = forall a. HasCallStack => String -> a
error String
"Unexpected end of types."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [] [Name]
_  = forall a. HasCallStack => String -> a
error String
"Unexpected end of names."
matchOrdArguments [Type]
_ [(TypePat, ExpQ)]
_ Name
_ Set Name
_ [Type]
_  [Name]
_  [] = 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 [Q Match]
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) forall a. Set a
Set.empty (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con) [Name]
xv [Name]
yv
  -- Return match expression
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
yp) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
rv) []
         forall a. a -> [a] -> [a]
: case Maybe ExpQ
mbYn of
             Maybe ExpQ
Nothing -> []
             Just ExpQ
yn -> [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
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 [Q Match]
mkOrdF DatatypeInfo
d [(TypePat, ExpQ)]
pats = [Type]
-> [(TypePat, ExpQ)]
-> ConstructorInfo
-> Integer
-> Maybe ExpQ
-> [Name]
-> Q [Q Match]
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 <- 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 ->  forall a. a -> Maybe a
Just 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
_) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| traverse $(f) $(v) |]
        AppT (VarT Name
_) Type
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(f) $(v) |]
        Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> Q Match
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 <- 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) (forall (m :: * -> *). Quote m => Name -> m Exp
varE 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 (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE ExpQ
e (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v)) [(Name, Maybe Exp)]
r
      mkRes ExpQ
e ((Name
_,Just{}):[(Name, Maybe Exp)]
r) = do
        Name
v <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v] (ExpQ -> [(Name, Maybe Exp)] -> ExpQ
mkRes (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE ExpQ
e (forall (m :: * -> *). Quote m => Name -> m Exp
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 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo -> Exp
conExpr ConstructorInfo
c0)) [(Name, Maybe Exp)]
pargs) (forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
exprs)
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (forall (m :: * -> *). Quote m => m Exp -> m Body
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralTraversal" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a] forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a)
      ([Type] -> [(TypePat, ExpQ)] -> ExpQ -> ConstructorInfo -> Q Match
traverseAppMatch (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
d) [(TypePat, ExpQ)]
pats0 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) 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) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
asTypeCon String
fn Type
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
fn 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralHash" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
s <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DatatypeInfo
-> [(TypePat, ExpQ)]
-> ExpQ
-> Integer
-> ConstructorInfo
-> Q Match
matchHashCtor DatatypeInfo
d [(TypePat, ExpQ)]
pats (forall (m :: * -> *). Quote m => Name -> m Exp
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
-> Q Match
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 <- 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> (ExpQ, Type) -> ExpQ
go ExpQ
s1 (forall a b. [a] -> [b] -> [(a, b)]
zip (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
c))
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (forall (m :: * -> *). Quote m => m Exp -> m Body
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Type -> Q Name
asTypeCon String
"structuralShowPrec" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
tpq
  Name
p <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_p"
  Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a) (ExpQ -> ConstructorInfo -> Q Match
matchShowCtor (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) 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 -> Q Match
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
conPCompat Name
nm (Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars)
  let go :: m Exp -> Name -> m Exp
go m Exp
s Name
e = [| $(s) . showChar ' ' . showsPrec 11 $(varE e) |]
  let ctor :: ExpQ
ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |]
  let rhs :: ExpQ
rhs | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vars = ExpQ
ctor
          | Bool
otherwise = [| showParen ($(p) >= 11) $(foldl go ctor vars) |]
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
pat) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
rhs) []

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

-- | Generate a \"repr\" or singleton type from a data kind. For nullary
-- constructors, this works as follows:
--
-- @
-- data T1 = A | B | C
-- \$(mkRepr ''T1)
-- ======>
-- data T1Repr (tp :: T1)
--   where
--     ARepr :: T1Repr 'A
--     BRepr :: T1Repr 'B
--     CRepr :: T1Repr 'C
-- @
--
-- For constructors with fields, we assume each field type @T@ already has a
-- corresponding repr type @TRepr :: T -> *@.
--
-- @
-- data T2 = T2_1 T1 | T2_2 T1
-- \$(mkRepr ''T2)
-- ======>
-- data T2Repr (tp :: T2)
--   where
--     T2_1Repr :: T1Repr tp -> T2Repr ('T2_1 tp)
--     T2_2Repr :: T1Repr tp -> T2Repr ('T2_2 tp)
-- @
--
-- Constructors with multiple fields work fine as well:
--
-- @
-- data T3 = T3 T1 T2
-- \$(mkRepr ''T3)
-- ======>
-- data T3Repr (tp :: T3)
--   where
--     T3Repr :: T1Repr tp1 -> T2Repr tp2 -> T3Repr ('T3 tp1 tp2)
-- @
--
-- This is generally compatible with other \"repr\" types provided by
-- @parameterized-utils@, such as @NatRepr@ and @PeanoRepr@:
--
-- @
-- data T4 = T4_1 Nat | T4_2 Peano
-- \$(mkRepr ''T4)
-- ======>
-- data T4Repr (tp :: T4)
--   where
--     T4Repr :: NatRepr tp1 -> PeanoRepr tp2 -> T4Repr ('T4 tp1 tp2)
-- @
--
-- The data kind must be \"simple\", i.e. it must be monomorphic and only
-- contain user-defined data constructors (no lists, tuples, etc.). For example,
-- the following will not work:
--
-- @
-- data T5 a = T5 a
-- \$(mkRepr ''T5)
-- ======>
-- Foo.hs:1:1: error:
--     Exception when trying to run compile-time code:
--       mkRepr cannot be used on polymorphic data kinds.
-- @
--
-- Similarly, this will not work:
--
-- @
-- data T5 = T5 [Nat]
-- \$(mkRepr ''T5)
-- ======>
-- Foo.hs:1:1: error:
--     Exception when trying to run compile-time code:
--       mkRepr cannot be used on this data kind.
-- @
--
-- Note that at a minimum, you will need the following extensions to use this macro:
--
-- @
-- {-\# LANGUAGE DataKinds \#-}
-- {-\# LANGUAGE GADTs \#-}
-- {-\# LANGUAGE KindSignatures \#-}
-- {-\# LANGUAGE TemplateHaskell \#-}
-- @
mkRepr :: Name -> DecsQ
mkRepr :: Name -> DecsQ
mkRepr Name
typeName = do
  let reprTypeName :: Name
reprTypeName = Name -> Name
mkReprName Name
typeName
      varName :: Name
varName = String -> Name
mkName String
"tp"
  DatatypeInfo
info <- Name -> Q DatatypeInfo
lookupDataType' Name
typeName
  let gc :: ConstructorInfo -> Q Con
gc ConstructorInfo
ci = do
        let ctorName :: Name
ctorName = ConstructorInfo -> Name
constructorName ConstructorInfo
ci
            reprCtorName :: Name
reprCtorName = Name -> Name
mkReprName Name
ctorName
            ctorFieldTypeNames :: [Name]
ctorFieldTypeNames = Type -> Name
getCtorName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci
            ctorFieldReprNames :: [Name]
ctorFieldReprNames = Name -> Name
mkReprName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ctorFieldTypeNames
        -- Generate a list of type variables to be supplied as type arguments
        -- for each repr argument.
        [Name]
tvars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"tp")
        let appliedType :: Type
appliedType =
              forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
PromotedT (ConstructorInfo -> Name
constructorName ConstructorInfo
ci)) (Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tvars)
            ctorType :: Type
ctorType = Type -> Type -> Type
AppT (Name -> Type
ConT Name
reprTypeName) Type
appliedType
            ctorArgTypes :: [(Bang, Type)]
ctorArgTypes =
              forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Name
v -> (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type -> Type -> Type
AppT (Name -> Type
ConT Name
n) (Name -> Type
VarT Name
v))) [Name]
ctorFieldReprNames [Name]
tvars
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> [(Bang, Type)] -> Type -> Con
GadtC
          [Name
reprCtorName]
          [(Bang, Type)]
ctorArgTypes
          Type
ctorType
  [Con]
ctors <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstructorInfo -> Q Con
gc (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
reprTypeName
             [Name -> Type -> TyVarBndr ()
kindedTV Name
varName (Name -> Type
ConT Name
typeName)]
             forall a. Maybe a
Nothing
             [Con]
ctors
             []
           ]
  where getCtorName :: Type -> Name
        getCtorName :: Type -> Name
getCtorName Type
c = case Type
c of
          ConT Name
nm -> Name
nm
          VarT Name
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkRepr cannot be used on polymorphic data kinds."
          Type
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkRepr cannot be used on this data kind."

-- | Generate @KnownRepr@ instances for each constructor of a data kind. Given a
-- data kind @T@, we assume a repr type @TRepr (t :: T)@ is in scope with
-- structure that perfectly matches @T@ (using 'mkRepr' to generate the repr
-- type will guarantee this).
--
-- Given data kinds @T1@, @T2@, and @T3@ from the documentation of 'mkRepr', and
-- the associated repr types @T1Repr@, @T2Repr@, and @T3Repr@, we can use
-- 'mkKnownReprs' to generate these instances like so:
--
-- @
-- \$(mkKnownReprs ''T1)
-- ======>
-- instance KnownRepr T1Repr 'A where
--   knownRepr = ARepr
-- instance KnownRepr T1Repr 'B where
--   knownRepr = BRepr
-- instance KnownRepr T1Repr 'C where
--   knownRepr = CRepr
-- @
--
-- @
-- \$(mkKnownReprs ''T2)
-- ======>
-- instance KnownRepr T1Repr tp =>
--          KnownRepr T2Repr ('T2_1 tp) where
--   knownRepr = T2_1Repr knownRepr
-- @
--
-- @
-- \$(mkKnownReprs ''T3)
-- ======>
-- instance (KnownRepr T1Repr tp1, KnownRepr T2Repr tp2) =>
--          KnownRepr T3Repr ('T3_1 tp1 tp2) where
--   knownRepr = T3_1Repr knownRepr knownRepr
-- @
--
-- The same restrictions that apply to 'mkRepr' also apply to 'mkKnownReprs'.
-- The data kind must be \"simple\", i.e. it must be monomorphic and only
-- contain user-defined data constructors (no lists, tuples, etc.).
--
-- Note that at a minimum, you will need the following extensions to use this macro:
--
-- @
-- {-\# LANGUAGE DataKinds \#-}
-- {-\# LANGUAGE GADTs \#-}
-- {-\# LANGUAGE KindSignatures \#-}
-- {-\# LANGUAGE MultiParamTypeClasses \#-}
-- {-\# LANGUAGE TemplateHaskell \#-}
-- @
--
-- Also, 'mkKnownReprs' must be used in the same module as the definition of
-- the repr type (not necessarily for the data kind).
mkKnownReprs :: Name -> DecsQ
mkKnownReprs :: Name -> DecsQ
mkKnownReprs Name
typeName = do
  Type
kr <- [t|KnownRepr|]
  let krFName :: Name
krFName = String -> Name
mkName String
"knownRepr"
      reprTypeName :: Name
reprTypeName = Name -> Name
mkReprName Name
typeName
  DatatypeInfo
typeInfo <- Name -> Q DatatypeInfo
lookupDataType' Name
typeName
  DatatypeInfo
reprInfo <- Name -> Q DatatypeInfo
lookupDataType' Name
reprTypeName
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
typeInfo) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
reprInfo)) forall a b. (a -> b) -> a -> b
$ \(ConstructorInfo
tci, ConstructorInfo
rci) -> do
    [Name]
vars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
tci)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"tp")
    [Type]
krReqs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
tci) [Name]
vars) forall a b. (a -> b) -> a -> b
$ \(Type
tfld, Name
v) -> do
      let fldReprName :: Name
fldReprName = Name -> Name
mkReprName (Type -> Name
getCtorName Type
tfld)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
kr (Name -> Type
ConT Name
fldReprName)) (Name -> Type
VarT Name
v)
    let appliedType :: Type
appliedType =
          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
PromotedT (ConstructorInfo -> Name
constructorName ConstructorInfo
tci)) (Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars)
        krConstraint :: Type
krConstraint = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
kr (Name -> Type
ConT Name
reprTypeName)) Type
appliedType
        krExp :: Exp
krExp = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (ConstructorInfo -> Name
constructorName ConstructorInfo
rci)) forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const (Name -> Exp
VarE Name
krFName)) [Name]
vars
        krDec :: Dec
krDec = Name -> [Clause] -> Dec
FunD Name
krFName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
krExp) []]

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type]
krReqs Type
krConstraint [Dec
krDec]
  where getCtorName :: Type -> Name
        getCtorName :: Type -> Name
getCtorName Type
c = case Type
c of
          ConT Name
nm -> Name
nm
          VarT Name
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkKnownReprs cannot be used on polymorphic data kinds."
          Type
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkKnownReprs cannot be used on this data kind."

mkReprName :: Name -> Name
mkReprName :: Name -> Name
mkReprName Name
nm = String -> Name
mkName (Name -> String
nameBase Name
nm forall a. [a] -> [a] -> [a]
++ String
"Repr")

conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
                           []
#endif
                           [Pat]
pats

-- $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@.

-- $reprs
--
-- When working with data kinds with run-time representatives, we encourage
-- users of @parameterized-utils@ to use the following convention. Given a data
-- kind defined by
--
-- @
-- data T = ...
-- @
--
-- users should also supply a GADT @TRepr@ parameterized by @T@, e.g.
--
-- @
-- data TRepr (t :: T) where ...
-- @
--
-- Each constructor of @TRepr@ should correspond to a constructor of @T@. If @T@
-- is defined by
--
-- @
-- data T = A | B Nat
-- @
--
-- we have a corresponding
--
-- @
-- data TRepr (t :: T) where
--   ARepr :: TRepr 'A
--   BRepr :: NatRepr w -> TRepr ('B w)
-- @
--
-- Assuming the user of @parameterized-utils@ follows this convention, we
-- provide the Template Haskell construct 'mkRepr' to automate the creation of
-- the @TRepr@ GADT. We also provide 'mkKnownReprs', which generates 'KnownRepr'
-- instances for that GADT type. See the documentation for those two functions
-- for more detailed explanations.
--
-- NB: These macros are inspired by the corresponding macros provided by
-- @singletons-th@, and the \"repr\" programming idiom is very similar to the one
-- used by @singletons@.