dependent-sum-template-0.1.0.3/0000755000000000000000000000000007346545000014423 5ustar0000000000000000dependent-sum-template-0.1.0.3/ChangeLog.md0000755000000000000000000000055307346545000016602 0ustar0000000000000000# Revision history for dependent-sum ## 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.1.0.3/Setup.lhs0000644000000000000000000000011607346545000016231 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain dependent-sum-template-0.1.0.3/dependent-sum-template.cabal0000644000000000000000000000322207346545000021767 0ustar0000000000000000name: dependent-sum-template version: 0.1.0.3 stability: experimental cabal-version: >= 1.8 build-type: Simple author: James Cook maintainer: Ryan Trinkle license: PublicDomain homepage: https://github.com/obsidiansystems/dependent-sum category: Unclassified synopsis: Template Haskell code to generate instances of classes in dependent-sum package description: Template Haskell code to generate instances of classes in dependent-sum package, such as 'GEq' and 'GCompare'. tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3 extra-source-files: ChangeLog.md source-repository head type: git location: https://github.com/obsidiansystems/dependent-sum Library if impl(ghc < 7.10) buildable: False hs-source-dirs: src exposed-modules: Data.GADT.Compare.TH Data.GADT.Show.TH other-modules: Data.Dependent.Sum.TH.Internal build-depends: base >= 3 && <5, dependent-sum >= 0.4.1 && < 0.8, template-haskell, th-extras >= 0.0.0.2 test-suite test if impl(ghc < 8.0) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test.hs build-depends: base , constraints-extras , dependent-sum , dependent-sum-template dependent-sum-template-0.1.0.3/src/Data/Dependent/Sum/TH/0000755000000000000000000000000007346545000021050 5ustar0000000000000000dependent-sum-template-0.1.0.3/src/Data/Dependent/Sum/TH/Internal.hs0000644000000000000000000000506607346545000023167 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} -- | Shared functions for dependent-sum-template module Data.Dependent.Sum.TH.Internal where import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Extras 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, []) -- 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 -> (Q Type -> Q Type) -> ([TyVarBndr] -> [Con] -> Q Dec) -> Dec -> Q [Dec] deriveForDec className _ f (InstanceD overlaps cxt classHead decs) = do let (givenClassName, firstParam : _) = classHeadToParams classHead when (givenClassName /= className) $ fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName let dataTypeName = headOfType firstParam dataTypeInfo <- reify dataTypeName case dataTypeInfo of TyConI (DataD dataCxt name bndrs _ cons _) -> do dec <- f bndrs cons return [InstanceD overlaps cxt classHead [dec]] _ -> fail $ "while deriving " ++ show className ++ ": the name of an algebraic data type constructor is required" deriveForDec className makeClassHead f (DataD dataCxt name bndrs _ cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (makeClassHead $ conT name) [dec] dec = f bndrs cons #if __GLASGOW_HASKELL__ >= 808 deriveForDec className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst #else deriveForDec className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) clhead [dec] #if __GLASGOW_HASKELL__ >= 808 clhead = makeClassHead $ return $ initTy ty bndrs = [PlainTV v | PlainTV v <- maybe [] id tvBndrs] initTy (AppT ty _) = ty #else clhead = makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs)) -- TODO: figure out proper number of family parameters vs instance parameters bndrs = [PlainTV v | VarT v <- tail tyArgs ] #endif dec = f bndrs cons dependent-sum-template-0.1.0.3/src/Data/GADT/Compare/0000755000000000000000000000000007346545000020170 5ustar0000000000000000dependent-sum-template-0.1.0.3/src/Data/GADT/Compare/TH.hs0000644000000000000000000001356507346545000021051 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} module Data.GADT.Compare.TH ( DeriveGEQ(..) , DeriveGCompare(..) , GComparing, runGComparing, geq', compare' ) where import Control.Applicative import Control.Monad import Data.Dependent.Sum import Data.Dependent.Sum.TH.Internal import Data.Functor.Identity import Data.GADT.Compare import Data.Traversable (for) import Data.Type.Equality ((:~:) (..)) import Language.Haskell.TH import Language.Haskell.TH.Extras -- A type class purely for overloading purposes class DeriveGEQ t where deriveGEq :: t -> Q [Dec] instance DeriveGEQ Name where deriveGEq typeName = do typeInfo <- reify typeName case typeInfo of TyConI dec -> deriveGEq dec _ -> fail "deriveGEq: the name of a type constructor is required" instance DeriveGEQ Dec where deriveGEq = deriveForDec ''GEq (\t -> [t| GEq $t |]) geqFunction 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 bndrs cons = funD 'geq ( map (geqClause bndrs) cons ++ [ clause [wildP, wildP] (normalB [| Nothing |]) [] | length cons /= 1 ] ) geqClause bndrs con = do let argTypes = argTypesOfCon con needsGEq argType = any ((`occursInType` argType) . nameOfBinder) (bndrs ++ varsBoundInCon con) nArgs = length argTypes lArgNames <- replicateM nArgs (newName "x") rArgNames <- replicateM nArgs (newName "y") clause [ conP conName (map varP lArgNames) , conP conName (map varP rArgNames) ] ( normalB $ doE ( [ if needsGEq argType then bindS (conP 'Refl []) [| geq $(varE lArg) $(varE rArg) |] else noBindS [| guard ($(varE lArg) == $(varE rArg)) |] | (lArg, rArg, argType) <- zip3 lArgNames rArgNames argTypes ] ++ [ noBindS [| return Refl |] ] ) ) [] where conName = nameOfCon con -- 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 = GComparing . Right GComparing (Left x) >>= f = GComparing (Left x) GComparing (Right x) >>= f = f x instance Applicative (GComparing a b) where pure = return (<*>) = 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 class DeriveGCompare t where deriveGCompare :: t -> Q [Dec] instance DeriveGCompare Name where deriveGCompare typeName = do typeInfo <- reify typeName case typeInfo of TyConI dec -> deriveGCompare dec _ -> fail "deriveGCompare: the name of a type constructor is required" instance DeriveGCompare Dec where deriveGCompare = deriveForDec ''GCompare (\t -> [t| GCompare $t |]) gcompareFunction 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 boundVars cons | null cons = funD 'gcompare [clause [] (normalB [| \x y -> seq x (seq y undefined) |]) []] | otherwise = funD 'gcompare (concatMap gcompareClauses cons) where -- for every constructor, first check for equality (recursively comparing -- arguments) then add catch-all cases; all not-yet-matched patterns are -- "greater than" the constructor under consideration. gcompareClauses con = [ mainClause con , clause [recP conName [], wildP] (normalB [| GLT |]) [] , clause [wildP, recP conName []] (normalB [| GGT |]) [] ] where conName = nameOfCon con needsGCompare argType con = any ((`occursInType` argType) . nameOfBinder) (boundVars ++ varsBoundInCon con) -- main clause; using the 'GComparing' monad, compare all arguments to the -- constructor recursively, attempting to unify type variables by recursive -- calls to gcompare whenever needed (that is, whenever a constructor argument's -- type contains a variable bound in the data declaration or in the constructor's -- type signature) mainClause con = do let conName = nameOfCon con argTypes = argTypesOfCon con nArgs = length argTypes lArgNames <- replicateM nArgs (newName "x") rArgNames <- replicateM nArgs (newName "y") clause [ conP conName (map varP lArgNames) , conP conName (map varP rArgNames) ] ( normalB [| runGComparing $ $(doE ( [ if needsGCompare argType con then bindS (conP 'Refl []) [| geq' $(varE lArg) $(varE rArg) |] else noBindS [| compare' $(varE lArg) $(varE rArg) |] | (lArg, rArg, argType) <- zip3 lArgNames rArgNames argTypes ] ++ [ noBindS [| return GEQ |] ] ) ) |] ) [] dependent-sum-template-0.1.0.3/src/Data/GADT/Show/0000755000000000000000000000000007346545000017522 5ustar0000000000000000dependent-sum-template-0.1.0.3/src/Data/GADT/Show/TH.hs0000644000000000000000000000355307346545000020377 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell #-} module Data.GADT.Show.TH ( DeriveGShow(..) ) where import Control.Applicative import Control.Monad import Data.Dependent.Sum import Data.Dependent.Sum.TH.Internal import Data.Functor.Identity import Data.GADT.Show import Data.Traversable (for) import Data.List import Language.Haskell.TH import Language.Haskell.TH.Extras class DeriveGShow t where deriveGShow :: t -> Q [Dec] instance DeriveGShow Name where deriveGShow typeName = do typeInfo <- reify typeName case typeInfo of TyConI dec -> deriveGShow dec _ -> fail "deriveGShow: the name of a type constructor is required" instance DeriveGShow Dec where deriveGShow = deriveForDec ''GShow (\t -> [t| GShow $t |]) $ \_ -> gshowFunction 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 = funD 'gshowsPrec . map gshowClause gshowClause con = do let conName = nameOfCon con argTypes = argTypesOfCon con nArgs = length argTypes precName = mkName "p" argNames <- replicateM nArgs (newName "x") let precPat = if null argNames then wildP else varP precName clause [precPat, conP conName (map varP argNames)] (normalB (gshowBody (varE precName) conName argNames)) [] showsName name = [| showString $(litE . stringL $ nameBase name) |] gshowBody prec conName [] = showsName conName gshowBody prec conName argNames = [| showParen ($prec > 10) $( composeExprs $ intersperse [| showChar ' ' |] ( showsName conName : [ [| showsPrec 11 $arg |] | argName <- argNames, let arg = varE argName ] )) |] dependent-sum-template-0.1.0.3/test/0000755000000000000000000000000007346545000015402 5ustar0000000000000000dependent-sum-template-0.1.0.3/test/test.hs0000644000000000000000000001273407346545000016724 0ustar0000000000000000{-# 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 #-} import Control.Monad import Data.Dependent.Sum 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 Baz a where L :: Qux a -> Int -> Baz [a] data Qux a where FB :: Foo (a -> b) -> Bar b -> Qux (a -> (b, b)) deriveGEq ''Foo deriveGEq ''Bar deriveGEq ''Baz deriveGEq ''Qux deriveGCompare ''Foo deriveGCompare ''Bar deriveGCompare ''Baz deriveGCompare ''Qux instance Show (Foo a) where showsPrec = gshowsPrec instance Show (Bar a) where showsPrec = gshowsPrec instance Show (Baz a) where showsPrec = gshowsPrec instance Show (Qux a) where showsPrec = gshowsPrec deriveGShow ''Foo deriveGShow ''Bar deriveGShow ''Baz deriveGShow ''Qux 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 -- 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 (Spleeb a) instance GCompare a => GCompare (Spleeb a) instance Show (a Double) => GShow (Spleeb a) |] concat <$> sequence [ deriveGEq geqInst , deriveGCompare gcompareInst , deriveGShow gshowInst ] instance Show (a Double) => Show (Spleeb a b) where showsPrec = gshowsPrec -- 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