dependent-sum-template-0.0.0.6/0000755007247200724600000000000013113673276017106 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/dependent-sum-template.cabal0000644007247200724600000000232513113673276024455 0ustar00nixbldnixbld00000000000000name: dependent-sum-template version: 0.0.0.6 stability: experimental cabal-version: >= 1.8 build-type: Simple author: James Cook maintainer: Ryan Trinkle license: PublicDomain homepage: /dev/null 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'. source-repository head type: git location: https://github.com/mokus0/dependent-sum-template Library hs-source-dirs: src exposed-modules: Data.GADT.Compare.TH Data.GADT.Show.TH build-depends: base >= 3 && <5, dependent-sum >= 0.2 && < 0.5, template-haskell, th-extras >= 0.0.0.2 test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test.hs build-depends: base , dependent-sum , dependent-sum-template dependent-sum-template-0.0.0.6/Setup.lhs0000644007247200724600000000011613113673276020714 0ustar00nixbldnixbld00000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain dependent-sum-template-0.0.0.6/test/0000755007247200724600000000000013113673276020065 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/test/test.hs0000644007247200724600000001055613113673276021407 0ustar00nixbldnixbld00000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} import Control.Monad import Data.Dependent.Sum import Data.Functor.Identity import Data.GADT.Compare import Data.GADT.Compare.TH import Data.GADT.Show import Data.GADT.Show.TH data MySum :: * -> * where MySum_Int :: MySum Int MySum_String :: MySum String deriving instance Show (MySum a) deriveGShow ''MySum deriveGEq ''MySum deriveGCompare ''MySum main :: IO () main = do guard $ show MySum_Int == gshow MySum_Int guard $ show MySum_String == gshow MySum_String guard $ (MySum_Int `geq` MySum_Int) == Just Refl guard $ (MySum_Int `gcompare` MySum_Int) == GEQ guard $ (MySum_String `geq` MySum_String) == Just Refl guard $ (MySum_String `gcompare` MySum_String) == GEQ guard $ (MySum_Int `gcompare` MySum_String) == GLT guard $ (MySum_String `gcompare` MySum_Int) == GGT 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 dependent-sum-template-0.0.0.6/src/0000755007247200724600000000000013113673276017675 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/src/Data/0000755007247200724600000000000013113673276020546 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/src/Data/GADT/0000755007247200724600000000000013113673276021265 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/src/Data/GADT/Show/0000755007247200724600000000000013113673276022205 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/src/Data/GADT/Show/TH.hs0000644007247200724600000000672013113673276023061 0ustar00nixbldnixbld00000000000000{-# LANGUAGE CPP, TemplateHaskell #-} module Data.GADT.Show.TH ( DeriveGShow(..) ) where import Control.Applicative import Control.Monad import Data.GADT.Show 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGShow (InstanceD overlaps cxt (AppT instType dataType) decs) #else deriveGShow (InstanceD cxt (AppT instType dataType) decs) #endif | headOfType instType == ''GShow = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 TyConI (DataD dataCxt name bndrs _ cons _) -> do #else TyConI (DataD dataCxt name bndrs cons _) -> do #endif gshowDec <- gshowFunction cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 return [InstanceD overlaps cxt (AppT instType dataType) [gshowDec]] #else return [InstanceD cxt (AppT instType dataType) [gshowDec]] #endif _ -> fail "deriveGShow: the name of an algebraic data type constructor is required" #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGShow (DataD dataCxt name bndrs _ cons _) = return <$> inst #else deriveGShow (DataD dataCxt name bndrs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GShow) (conT name)) [gshowDec] gshowDec = gshowFunction cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 #if __GLASGOW_HASKELL__ >= 800 deriveGShow (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst #else deriveGShow (DataInstD dataCxt name tyArgs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GShow) (foldl1 appT (map return $ (ConT name : init tyArgs)))) [gshowDec] -- TODO: figure out proper number of family parameters vs instance parameters gshowDec = gshowFunction cons #endif 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") clause [varP precName, 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.0.0.6/src/Data/GADT/Compare/0000755007247200724600000000000013113673276022653 5ustar00nixbldnixbld00000000000000dependent-sum-template-0.0.0.6/src/Data/GADT/Compare/TH.hs0000644007247200724600000002311013113673276023517 0ustar00nixbldnixbld00000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-} #endif module Data.GADT.Compare.TH ( DeriveGEQ(..) , DeriveGCompare(..) , GComparing, runGComparing, geq', compare' ) where import Control.Applicative import Control.Monad import Data.GADT.Compare 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGEq (InstanceD overlaps cxt (AppT instType dataType) decs) #else deriveGEq (InstanceD cxt (AppT instType dataType) decs) #endif | headOfType instType == ''GEq = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 TyConI (DataD dataCxt name bndrs _ cons _) -> do #else TyConI (DataD dataCxt name bndrs cons _) -> do #endif geqDec <- geqFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 return [InstanceD overlaps cxt (AppT instType dataType) [geqDec]] #else return [InstanceD cxt (AppT instType dataType) [geqDec]] #endif _ -> fail "deriveGEq: the name of an algebraic data type constructor is required" #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGEq (DataD dataCxt name bndrs _ cons _) = return <$> inst #else deriveGEq (DataD dataCxt name bndrs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GEq) (conT name)) [geqDec] geqDec = geqFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 #if __GLASGOW_HASKELL__ >= 800 deriveGEq (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst #else deriveGEq (DataInstD dataCxt name tyArgs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GEq) (foldl1 appT (map return $ (ConT name : init tyArgs)))) [geqDec] -- TODO: figure out proper number of family parameters vs instance parameters bndrs = [PlainTV v | VarT v <- tail tyArgs ] geqDec = geqFunction bndrs cons #endif 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGCompare (InstanceD overlaps cxt (AppT instType dataType) decs) #else deriveGCompare (InstanceD cxt (AppT instType dataType) decs) #endif | headOfType instType == ''GCompare = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 TyConI (DataD dataCxt name bndrs _ cons _) -> do #else TyConI (DataD dataCxt name bndrs cons _) -> do #endif gcompareDec <- gcompareFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 return [InstanceD overlaps cxt (AppT instType dataType) [gcompareDec]] #else return [InstanceD cxt (AppT instType dataType) [gcompareDec]] #endif _ -> fail "deriveGCompare: the name of an algebraic data type constructor is required" #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 deriveGCompare (DataD dataCxt name bndrs _ cons _) = return <$> inst #else deriveGCompare (DataD dataCxt name bndrs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GCompare) (conT name)) [gcompareDec] gcompareDec = gcompareFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 #if __GLASGOW_HASKELL__ >= 800 deriveGCompare (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst #else deriveGCompare (DataInstD dataCxt name tyArgs cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GCompare) (foldl1 appT (map return $ (ConT name : init tyArgs)))) [gcompareDec] -- TODO: figure out proper number of family parameters vs instance parameters bndrs = [PlainTV v | VarT v <- tail tyArgs ] gcompareDec = gcompareFunction bndrs cons #endif 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 |] ] ) ) |] ) []