dependent-sum-template-0.2.0.0/0000755000000000000000000000000007346545000014421 5ustar0000000000000000dependent-sum-template-0.2.0.0/ChangeLog.md0000644000000000000000000000246207346545000016576 0ustar0000000000000000# Revision history for dependent-sum-template ## 0.2.0.0 - 2023-08-01 * Recover compatibility with template-haskell 2.18, which was lost in 0.1.2.0 * deriveGShow will generate code that uses Show instances for every argument to a constructor, apart from those of the type that it is generating an instance for. * Drop support for GHC 9.2 and 9.4 due to [a bug in reifyInstances](https://gitlab.haskell.org/ghc/ghc/-/issues/23743) ## 0.1.2.0 - 2023-07-11 * Rework a lot of the logic using th-abstraction to get structural information about data types and to normalize their representation. This should allow the deriving functions to work on a much wider range of types. * Change dependency to just be on `some`, not `dependent-sum`, as we just need the reexported classes. ## 0.1.1.1 - 2021-12-30 * Fix warning with GHC 9.2 about non-canonical `return`. ## 0.1.1.0 revision 1 - 2021-11-30 * Add bound to `th-abstraction` to prevent build failure. ## 0.1.1.0 - 2021-11-25 * Support GHC 9.0 ## 0.1.0.3 - 2020-03-24 * Relax version bounds on `dependent-sum` to include 0.7. ## 0.1.0.2 - 2020-03-23 * Update GitHub repository in cabal metadata. ## 0.1.0.1 - 2020-03-21 * Support GHC 8.8. ## 0.1.0.0 - 2019-03-21 * Remove code for generating instances of *Tag classes, as they were removed in dependent-sum-0.6. dependent-sum-template-0.2.0.0/ReadMe.md0000644000000000000000000000215407346545000016102 0ustar0000000000000000dependent-sum-template [![Build Status](https://travis-ci.org/obsidiansystems/dependent-sum-template.svg)](https://travis-ci.org/obsidiansystems/dependent-sum-template) [![Hackage](https://img.shields.io/hackage/v/dependent-sum-template.svg)](http://hackage.haskell.org/package/dependent-sum-template) ============== This library defines [Template Haskell](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/template_haskell.html) functions for deriving the `GEq`, `GCompare`, `GShow`, and `GRead` functions from the [`some`](https://hackage.haskell.org/package/some) library. - `GEq tag` is similar to an `Eq` instance for `tag a` except that with `geq`, values of types `tag a` and `tag b` may be compared, and in the case of equality, evidence that the types `a` and `b` are equal is provided. - `GCompare tag` is similar to the above for `Ord`, and provides `gcompare`, giving a `GOrdering` that gives similar evidence of type equality when values match. - `GShow tag` means that `tag a` has (the equivalent of) a `Show` instance. - `GRead tag` means that `tag a` has (the equivalent of) a `Read` instance. dependent-sum-template-0.2.0.0/Setup.lhs0000644000000000000000000000011607346545000016227 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain dependent-sum-template-0.2.0.0/dependent-sum-template.cabal0000644000000000000000000000374107346545000021773 0ustar0000000000000000name: dependent-sum-template version: 0.2.0.0 stability: experimental cabal-version: >= 1.10 build-type: Simple author: James Cook maintainer: Obsidian Systems, LLC license: PublicDomain homepage: https://github.com/obsidiansystems/dependent-sum-template category: Unclassified synopsis: Template Haskell code to generate instances of classes in some package description: Template Haskell code to generate instances of classes in some package, such as 'GEq' and 'GCompare'. tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.6.1 extra-source-files: ChangeLog.md , ReadMe.md source-repository head type: git location: https://github.com/obsidiansystems/dependent-sum-template Library if impl(ghc < 7.10) buildable: False hs-source-dirs: src default-language: Haskell2010 exposed-modules: Data.GADT.Compare.TH Data.GADT.Show.TH other-modules: Data.GADT.TH.Internal Data.GADT.Compare.Monad build-depends: base >= 3 && <5, some >= 1.0.1 && < 1.1, containers >= 0.5.9.2, mtl, template-haskell >= 2.11 && < 2.21, th-abstraction >= 0.4 test-suite test if impl(ghc < 8.0) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 main-is: test.hs build-depends: base , constraints-extras , dependent-sum-template , template-haskell , some , th-abstraction dependent-sum-template-0.2.0.0/src/Data/GADT/Compare/0000755000000000000000000000000007346545000020166 5ustar0000000000000000dependent-sum-template-0.2.0.0/src/Data/GADT/Compare/Monad.hs0000644000000000000000000000224007346545000021556 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} module Data.GADT.Compare.Monad ( GComparing , runGComparing , geq' , compare' ) where import Control.Applicative import Control.Monad import Data.GADT.Compare import Data.Type.Equality ((:~:) (..)) -- A monad allowing gcompare to be defined in the same style as geq newtype GComparing a b t = GComparing (Either (GOrdering a b) t) instance Functor (GComparing a b) where fmap f (GComparing x) = GComparing (either Left (Right . f) x) instance Monad (GComparing a b) where return = pure GComparing (Left x) >>= f = GComparing (Left x) GComparing (Right x) >>= f = f x instance Applicative (GComparing a b) where pure = GComparing . Right (<*>) = ap geq' :: GCompare t => t a -> t b -> GComparing x y (a :~: b) geq' x y = GComparing (case gcompare x y of GLT -> Left GLT GEQ -> Right Refl GGT -> Left GGT) compare' x y = GComparing $ case compare x y of LT -> Left GLT EQ -> Right () GT -> Left GGT runGComparing (GComparing x) = either id id x dependent-sum-template-0.2.0.0/src/Data/GADT/Compare/TH.hs0000644000000000000000000001523307346545000021041 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} module Data.GADT.Compare.TH ( DeriveGEQ(..) , DeriveGCompare(..) , module Data.GADT.Compare.Monad ) where import Control.Monad import Control.Monad.Writer import Data.GADT.TH.Internal import Data.Functor.Identity import Data.GADT.Compare import Data.GADT.Compare.Monad import Data.Type.Equality ((:~:) (..)) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map import Data.Map (Map) import Language.Haskell.TH import Language.Haskell.TH.Datatype -- A type class purely for overloading purposes class DeriveGEQ t where deriveGEq :: t -> Q [Dec] instance DeriveGEQ Name where deriveGEq typeName = do typeInfo <- reifyDatatype typeName let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] instTypes' = case reverse instTypes of [] -> fail "deriveGEq: Not enough type parameters" (_:xs) -> reverse xs instanceHead = AppT (ConT ''GEq) (foldl AppT (ConT typeName) instTypes') (clauses, cxt) <- runWriterT (mapM (geqClause paramVars) (datatypeCons typeInfo)) return [InstanceD Nothing cxt instanceHead [geqFunction clauses]] instance DeriveGEQ Dec where deriveGEq = deriveForDec ''GEq $ \typeInfo -> do let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] clauses <- mapM (geqClause paramVars) (datatypeCons typeInfo) return $ geqFunction clauses instance DeriveGEQ t => DeriveGEQ [t] where deriveGEq [it] = deriveGEq it deriveGEq _ = fail "deriveGEq: [] instance only applies to single-element lists" instance DeriveGEQ t => DeriveGEQ (Q t) where deriveGEq = (>>= deriveGEq) geqFunction :: [Clause] -> Dec geqFunction clauses = FunD 'geq $ clauses ++ [ Clause [WildP, WildP] (NormalB (ConE 'Nothing)) [] ] -- TODO: only include last clause if there's more than one constructor? geqClause :: Set Name -> ConstructorInfo -> WriterT Cxt Q Clause geqClause paramVars con = do let conName = constructorName con argTypes = constructorFields con conTyVars = Set.fromList (map tvName (constructorVars con)) needsGEq argType = not . Set.null $ Set.intersection (freeTypeVariables argType) (Set.union paramVars conTyVars) lArgNames <- forM argTypes $ \_ -> lift $ newName "x" rArgNames <- forM argTypes $ \_ -> lift $ newName "y" stmts <- forM (zip3 lArgNames rArgNames argTypes) $ \(l, r, t) -> do case t of AppT tyFun tyArg | needsGEq t -> do u <- lift $ reifyInstancesWithRigids paramVars ''GEq [tyFun] case u of [] -> tell [AppT (ConT ''GEq) tyFun] [(InstanceD _ cxt _ _)] -> tell cxt _ -> fail $ "More than one instance found for GEq (" ++ show (ppr tyFun) ++ "), and unsure what to do. Please report this." lift $ bindS (conP 'Refl []) [| geq $(varE l) $(varE r) |] _ -> lift $ noBindS [| guard ($(varE l) == $(varE r)) |] ret <- lift $ noBindS [| return Refl |] pats <- lift $ sequence [ conP conName (map varP lArgNames) , conP conName (map varP rArgNames) ] pure $ Clause pats (NormalB (doUnqualifiedE (stmts ++ [ret]))) [] class DeriveGCompare t where deriveGCompare :: t -> Q [Dec] instance DeriveGCompare Name where deriveGCompare typeName = do typeInfo <- reifyDatatype typeName let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] instTypes' = case reverse instTypes of [] -> fail "deriveGCompare: Not enough type parameters" (_:xs) -> reverse xs instanceHead = AppT (ConT ''GCompare) (foldl AppT (ConT typeName) instTypes') (clauses, cxt) <- runWriterT (fmap concat $ mapM (gcompareClauses paramVars) (datatypeCons typeInfo)) dec <- gcompareFunction clauses return [InstanceD Nothing cxt instanceHead [dec]] instance DeriveGCompare Dec where deriveGCompare = deriveForDec ''GCompare $ \typeInfo -> do let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] clauses <- mapM (gcompareClauses paramVars) (datatypeCons typeInfo) lift $ gcompareFunction (concat clauses) instance DeriveGCompare t => DeriveGCompare [t] where deriveGCompare [it] = deriveGCompare it deriveGCompare _ = fail "deriveGCompare: [] instance only applies to single-element lists" instance DeriveGCompare t => DeriveGCompare (Q t) where deriveGCompare = (>>= deriveGCompare) gcompareFunction :: [Clause] -> Q Dec gcompareFunction [] = funD 'gcompare [clause [] (normalB [| \x y -> seq x (seq y undefined) |]) []] gcompareFunction clauses = return $ FunD 'gcompare clauses gcompareClauses :: Set Name -> ConstructorInfo -> WriterT Cxt Q [Clause] gcompareClauses paramVars con = do let conName = constructorName con argTypes = constructorFields con conTyVars = Set.fromList (map tvName (constructorVars con)) needsGCompare argType = not . Set.null $ Set.intersection (freeTypeVariables argType) (Set.union paramVars conTyVars) lArgNames <- forM argTypes $ \_ -> lift $ newName "x" rArgNames <- forM argTypes $ \_ -> lift $ newName "y" stmts <- forM (zip3 lArgNames rArgNames argTypes) $ \(lArg, rArg, argType) -> case argType of AppT tyFun tyArg | needsGCompare argType -> do u <- lift $ reifyInstancesWithRigids paramVars ''GCompare [tyFun] case u of [] -> tell [AppT (ConT ''GCompare) tyFun] [(InstanceD _ cxt _ _)] -> tell cxt -- this might not be enough, may want to do full instance resolution. _ -> fail $ "More than one instance of GCompare (" ++ show (ppr tyFun) ++ ") found, and unsure what to do. Please report this." lift $ bindS (conP 'Refl []) [| geq' $(varE lArg) $(varE rArg) |] _ -> lift $ noBindS [| compare' $(varE lArg) $(varE rArg) |] ret <- lift $ noBindS [| return GEQ |] pats <- lift $ sequence [ conP conName (map varP lArgNames) , conP conName (map varP rArgNames) ] let main = Clause pats (NormalB (AppE (VarE 'runGComparing) (doUnqualifiedE (stmts ++ [ret])))) [] lt = Clause [RecP conName [], WildP] (NormalB (ConE 'GLT)) [] gt = Clause [WildP, RecP conName []] (NormalB (ConE 'GGT)) [] return [main, lt, gt] #if MIN_VERSION_template_haskell(2,17,0) doUnqualifiedE = DoE Nothing #else doUnqualifiedE = DoE #endif dependent-sum-template-0.2.0.0/src/Data/GADT/Show/0000755000000000000000000000000007346545000017520 5ustar0000000000000000dependent-sum-template-0.2.0.0/src/Data/GADT/Show/TH.hs0000644000000000000000000000643507346545000020377 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell #-} module Data.GADT.Show.TH ( DeriveGShow(..) ) where import Control.Applicative import Control.Monad import Control.Monad.Writer import Data.GADT.TH.Internal import Data.Functor.Identity import Data.GADT.Show import Data.Traversable (for) import Data.List import Data.Set (Set) import qualified Data.Set as Set import Language.Haskell.TH import Language.Haskell.TH.Datatype class DeriveGShow t where deriveGShow :: t -> Q [Dec] instance DeriveGShow Name where deriveGShow typeName = do typeInfo <- reifyDatatype typeName let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] instTypes' = case reverse instTypes of [] -> fail "deriveGEq: Not enough type parameters" (_:xs) -> reverse xs instanceHead = AppT (ConT ''GShow) (foldl AppT (ConT typeName) instTypes') (clauses, cxt) <- runWriterT (mapM (gshowClause typeName paramVars) (datatypeCons typeInfo)) return [InstanceD Nothing (datatypeContext typeInfo ++ cxt) instanceHead [gshowFunction clauses]] instance DeriveGShow Dec where deriveGShow = deriveForDec ''GShow $ \typeInfo -> do let instTypes = datatypeInstTypes typeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] clauses <- mapM (gshowClause (datatypeName typeInfo) paramVars) (datatypeCons typeInfo) return $ gshowFunction clauses instance DeriveGShow t => DeriveGShow [t] where deriveGShow [it] = deriveGShow it deriveGShow _ = fail "deriveGShow: [] instance only applies to single-element lists" instance DeriveGShow t => DeriveGShow (Q t) where deriveGShow = (>>= deriveGShow) gshowFunction :: [Clause] -> Dec gshowFunction clauses = FunD 'gshowsPrec clauses isApplicationOf :: Type -> Type -> Bool isApplicationOf t t' = t == t' || case t' of AppT u _ -> isApplicationOf t u _ -> False gshowClause :: Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause gshowClause typeName paramVars con = do let conName = constructorName con argTypes = constructorFields con conTyVars = Set.fromList (map tvName (constructorVars con)) precName <- lift $ newName "prec" argNames <- forM argTypes $ \_ -> lift $ newName "x" argShowExprs <- forM (zip argNames argTypes) $ \(n,t) -> do let useShow = do u <- lift $ reifyInstancesWithRigids paramVars ''Show [t] case u of (_:_) -> return () _ -> tell [AppT (ConT ''Show) t] return [| showsPrec 11 $(varE n) |] case t of AppT tyFun tyArg -> do if isApplicationOf (ConT typeName) tyFun then return [| gshowsPrec 11 $(varE n) |] else useShow _ -> useShow let precPat = if null argNames then wildP else varP precName lift $ clause [precPat, conP conName (map varP argNames)] (normalB (gshowBody (varE precName) conName argShowExprs)) [] showsName name = [| showString $(litE . stringL $ nameBase name) |] gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody prec conName [] = showsName conName gshowBody prec conName argShowExprs = let body = foldr (\e es -> [| $e . $es |]) [| id |] . intersperse [| showChar ' ' |] $ showsName conName : argShowExprs in [| showParen ($prec > 10) $body |] dependent-sum-template-0.2.0.0/src/Data/GADT/TH/0000755000000000000000000000000007346545000017113 5ustar0000000000000000dependent-sum-template-0.2.0.0/src/Data/GADT/TH/Internal.hs0000644000000000000000000001275407346545000021234 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} -- | Shared functions for dependent-sum-template module Data.GADT.TH.Internal where import Control.Monad import Control.Monad.Writer import qualified Data.Kind import Data.List (foldl', drop) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map import Data.Set (Set) import qualified Data.Set as Set import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr classHeadToParams :: Type -> (Name, [Type]) classHeadToParams t = (h, reverse reversedParams) where (h, reversedParams) = go t go :: Type -> (Name, [Type]) go t = case t of AppT f x -> let (h, reversedParams) = classHeadToParams f in (h, x : reversedParams) _ -> (headOfType t, []) -- Do not export this type family, it must remain empty. It's used as a way to trick GHC into not unifying certain type variables. type family Skolem :: k -> k skolemize :: Set Name -> Type -> Type skolemize rigids t = case t of ForallT bndrs cxt t' -> ForallT bndrs cxt (skolemize (Set.difference rigids (Set.fromList (map tvName bndrs))) t') AppT t1 t2 -> AppT (skolemize rigids t1) (skolemize rigids t2) SigT t k -> SigT (skolemize rigids t) k VarT v -> if Set.member v rigids then AppT (ConT ''Skolem) (VarT v) else t InfixT t1 n t2 -> InfixT (skolemize rigids t1) n (skolemize rigids t2) UInfixT t1 n t2 -> UInfixT (skolemize rigids t1) n (skolemize rigids t2) ParensT t -> ParensT (skolemize rigids t) _ -> t reifyInstancesBroken :: Q Bool reifyInstancesBroken = do a <- newName "a" ins <- reifyInstancesWithRigids' (Set.singleton a) ''Show [VarT a] pure $ not $ null ins reifyInstancesWithRigids' :: Set Name -> Name -> [Type] -> Q [InstanceDec] reifyInstancesWithRigids' rigids cls tys = reifyInstances cls (map (skolemize rigids) tys) reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec] reifyInstancesWithRigids rigids cls tys = do isBroken <- reifyInstancesBroken if isBroken then fail "Unsupported GHC version: 'reifyInstances' in this version of GHC returns instances when we expect an empty list. See https://gitlab.haskell.org/ghc/ghc/-/issues/23743" else reifyInstancesWithRigids' rigids cls tys -- | Determine the type variables which occur freely in a type. freeTypeVariables :: Type -> Set Name freeTypeVariables t = case t of ForallT bndrs _ t' -> Set.difference (freeTypeVariables t') (Set.fromList (map tvName bndrs)) AppT t1 t2 -> Set.union (freeTypeVariables t1) (freeTypeVariables t2) SigT t _ -> freeTypeVariables t VarT n -> Set.singleton n _ -> Set.empty subst :: Map Name Type -> Type -> Type subst s = f where f = \case ForallT bndrs cxt t -> let s' = Map.difference s (Map.fromList [(k,()) | k <- map tvName bndrs]) in ForallT bndrs cxt (subst s' t) AppT t t' -> AppT (f t) (f t') SigT t k -> SigT (f t) k VarT n -> case Map.lookup n s of Just t -> t Nothing -> VarT n InfixT t x t' -> InfixT (f t) x (f t') UInfixT t x t' -> UInfixT (f t) x (f t') x -> x -- Invoke the deriver for the given class instance. We assume that the type -- we're deriving for is always the first typeclass parameter, if there are -- multiple. deriveForDec :: Name -> (DatatypeInfo -> WriterT [Type] Q Dec) -> Dec -> Q [Dec] deriveForDec className f (InstanceD overlaps cxt instanceHead decs) = do let (givenClassName, firstParam : _) = classHeadToParams instanceHead when (givenClassName /= className) $ fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName let dataTypeName = headOfType firstParam dataTypeInfo <- reifyDatatype dataTypeName let instTypes = datatypeInstTypes dataTypeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] instTypes' = case reverse instTypes of [] -> fail "deriveGEq: Not enough type parameters" (_:xs) -> reverse xs generatedInstanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes') unifiedTypes <- unifyTypes [generatedInstanceHead, instanceHead] let newInstanceHead = applySubstitution unifiedTypes instanceHead newContext = applySubstitution unifiedTypes cxt -- We are not using the generated context that we collect from f, instead -- relying on a correct instance head from the user (dec, _) <- runWriterT $ f dataTypeInfo return [InstanceD overlaps newContext newInstanceHead [dec]] deriveForDec className f dataDec = do dataTypeInfo <- normalizeDec dataDec let instTypes = datatypeInstTypes dataTypeInfo paramVars = Set.unions [freeTypeVariables t | t <- instTypes] instTypes' = case reverse instTypes of [] -> fail "deriveGEq: Not enough type parameters" (_:xs) -> reverse xs instanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes') (dec, cxt') <- runWriterT (f dataTypeInfo) return [InstanceD Nothing (datatypeContext dataTypeInfo ++ cxt') instanceHead [dec]] headOfType :: Type -> Name headOfType = \case ForallT _ _ ty -> headOfType ty VarT name -> name ConT name -> name TupleT n -> tupleTypeName n ArrowT -> ''(->) ListT -> ''[] AppT t _ -> headOfType t dependent-sum-template-0.2.0.0/test/0000755000000000000000000000000007346545000015400 5ustar0000000000000000dependent-sum-template-0.2.0.0/test/test.hs0000644000000000000000000001466607346545000016730 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -ddump-splices #-} import Control.Monad import Data.Functor.Identity import Data.Constraint.Extras.TH import Data.GADT.Compare import Data.GADT.Compare.TH import Data.GADT.Show import Data.GADT.Show.TH import Data.Type.Equality data MySum :: * -> * where MySum_Int :: MySum Int MySum_String :: MySum String deriving instance Eq (MySum a) deriving instance Ord (MySum a) deriving instance Show (MySum a) deriveGShow ''MySum deriveGEq ''MySum deriveGCompare ''MySum deriveArgDict ''MySum data MyNestedSum :: * -> * where MyNestedSum_MySum :: MySum a -> MyNestedSum a MyNestedSum_Int :: Int -> MyNestedSum Int MyNestedSum_String :: [Int] -> MyNestedSum String deriving instance Eq (MyNestedSum a) deriving instance Ord (MyNestedSum a) deriving instance Show (MyNestedSum a) deriveGShow ''MyNestedSum deriveGEq ''MyNestedSum deriveGCompare ''MyNestedSum deriveArgDict ''MyNestedSum polyTests :: forall m f . ( MonadPlus m, Show (f Int), Show (f String) , GCompare f, GShow f) => (forall a. MySum a -> f a) -> m () polyTests f = do do let showSame :: forall a. Show (f a) => f a -> Bool showSame gadt = show gadt == gshow gadt guard $ showSame $ f MySum_Int guard $ showSame $ f MySum_String guard $ (f MySum_Int `geq` f MySum_Int) == Just Refl guard $ (f MySum_Int `gcompare` f MySum_Int) == GEQ guard $ (f MySum_String `geq` f MySum_String) == Just Refl guard $ (f MySum_String `gcompare` f MySum_String) == GEQ guard $ (f MySum_Int `gcompare` f MySum_String) == GLT guard $ (f MySum_String `gcompare` f MySum_Int) == GGT main :: IO () main = do polyTests id polyTests MyNestedSum_MySum return () --TODO: Figure out how to best use these test cases; just checking that they -- compile is useful, but it's probably more useful to check some properties as -- well -- test cases: should be able to generate instances for these -- (Bar requiring the existence of an instance for Foo) data Foo a where I :: Foo Int D :: Foo Double A :: Foo a -> Foo b -> Foo (a -> b) data Bar a where F :: Foo a -> Bar a S :: Bar String data Qux a where FB :: Foo (a -> b) -> Bar b -> Qux (a -> (b, b)) data Baz a where L :: Qux a -> Int -> Baz [a] deriveGEq ''Foo deriveGEq ''Bar deriveGEq ''Qux deriveGEq ''Baz deriveGCompare ''Foo deriveGCompare ''Bar deriveGCompare ''Qux deriveGCompare ''Baz deriveGShow ''Foo instance Show (Foo a) where showsPrec = gshowsPrec deriveGShow ''Bar instance Show (Bar a) where showsPrec = gshowsPrec deriveGShow ''Qux instance Show (Qux a) where showsPrec = gshowsPrec deriveGShow ''Baz instance Show (Baz a) where showsPrec = gshowsPrec data Squudge a where E :: Ord a => Foo a -> Squudge a deriveGEq ''Squudge deriveGCompare ''Squudge deriveGShow ''Squudge instance Show (Squudge a) where showsPrec = gshowsPrec data Splort a where Splort :: Squudge a -> a -> Splort a -- -- deriveGEq ''Splort -- This one theoretically could work (instance explicitly given below), but I don't think -- it's something I want to try to automagically support. It would require actually -- matching on sub-constructors, which could get pretty ugly, especially since it may -- not even be the case that a finite number of matches would suffice. instance GEq Splort where geq (Splort (E x1) x2) (Splort (E y1) y2) = do Refl <- geq x1 y1 guard (x2 == y2) Just Refl deriving instance Show a => Show (Splort a) instance GCompare Splort where gcompare (Splort (E x1) x2) (Splort (E y1) y2) = runGComparing $ do Refl <- geq' x1 y1 compare' x2 y2 return GEQ -- Also should work for empty types data Empty a deriveGEq ''Empty deriveGCompare ''Empty -- Also supports types with multiple parameters, by quoting empty instance declarations -- ([t||] brackets won't work because they can only quote types of kind *). data Spleeb a b where P :: a Double -> Qux b -> Spleeb a b deriveGEq ''Spleeb deriveGCompare ''Spleeb -- NB: We could also write: -- deriving instance (Show (a Double), Show (Qux b)) => Show (Spleeb a b) -- instance (Show (a Double)) => GShow (Spleeb a) deriveGShow ''Spleeb data SpleebHard a b where PH :: a Double -> Qux b -> SpleebHard a b PI :: a Int -> Foo b -> SpleebHard a b -- need a cleaner 'one-shot' way of defining these - the empty instances need to appear -- in the same quotation because the GEq context of the GCompare class causes stage -- restriction errors... seems like GHC shouldn't actually check things like that till -- the final splice, but whatever. do [geqInst, gcompareInst, gshowInst] <- [d| instance GEq a => GEq (SpleebHard a) instance GCompare a => GCompare (SpleebHard a) instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => GShow (SpleebHard a) |] concat <$> sequence [ deriveGEq geqInst , deriveGCompare gcompareInst , deriveGShow gshowInst ] instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => Show (SpleebHard a b) where showsPrec = gshowsPrec data SpleebHard2 a b where PH2 :: a Double -> Qux b -> SpleebHard2 a b PI2 :: a Int -> Foo b -> SpleebHard2 a b deriveGEq ''SpleebHard2 deriveGCompare ''SpleebHard2 deriveGShow ''SpleebHard2 -- another option; start from the declaration and juggle that a bit do decs <- [d| data Fnord a where Yarr :: Fnord Double; Grr :: Fnord (Int -> String) |] geqInst <- deriveGEq decs gcompareInst <- deriveGCompare decs gshowInst <- deriveGShow decs return $ concat [ decs , geqInst , gcompareInst , gshowInst ] instance Show (Fnord a) where showsPrec = gshowsPrec data MyTest a :: * -> * where MyTest_1 :: MyTest a () MyTest_2 :: MyTest a Int deriving instance Eq (MyTest a b) deriving instance Ord (MyTest a b) deriving instance Show (MyTest a b) deriveGShow ''MyTest deriveGEq ''MyTest deriveGCompare ''MyTest deriveArgDict ''MyTest