dependent-sum-template-0.0.0.4/0000755000000000000000000000000012556763675014446 5ustar0000000000000000dependent-sum-template-0.0.0.4/dependent-sum-template.cabal0000644000000000000000000000203012556763675022006 0ustar0000000000000000name: dependent-sum-template version: 0.0.0.4 stability: experimental cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: James Cook 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: git://github.com/mokus0/dependent-sum-template.git 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.4, template-haskell, th-extras >= 0.0.0.2 dependent-sum-template-0.0.0.4/Setup.lhs0000644000000000000000000000011612556763675016254 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain dependent-sum-template-0.0.0.4/src/0000755000000000000000000000000012556763675015235 5ustar0000000000000000dependent-sum-template-0.0.0.4/src/Data/0000755000000000000000000000000012556763675016106 5ustar0000000000000000dependent-sum-template-0.0.0.4/src/Data/GADT/0000755000000000000000000000000012556763675016625 5ustar0000000000000000dependent-sum-template-0.0.0.4/src/Data/GADT/Compare/0000755000000000000000000000000012556763675020213 5ustar0000000000000000dependent-sum-template-0.0.0.4/src/Data/GADT/Compare/TH.hs0000644000000000000000000002025212556763675021063 0ustar0000000000000000{-# 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 deriveGEq (InstanceD cxt (AppT instType dataType) decs) | headOfType instType == ''GEq = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of TyConI (DataD dataCxt name bndrs cons _) -> do geqDec <- geqFunction bndrs cons return [InstanceD cxt (AppT instType dataType) [geqDec]] _ -> fail "deriveGEq: the name of an algebraic data type constructor is required" deriveGEq (DataD dataCxt name bndrs cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GEq) (conT name)) [geqDec] geqDec = geqFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 deriveGEq (DataInstD dataCxt name tyArgs cons _) = return <$> inst 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 deriveGCompare (InstanceD cxt (AppT instType dataType) decs) | headOfType instType == ''GCompare = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of TyConI (DataD dataCxt name bndrs cons _) -> do gcompareDec <- gcompareFunction bndrs cons return [InstanceD cxt (AppT instType dataType) [gcompareDec]] _ -> fail "deriveGCompare: the name of an algebraic data type constructor is required" deriveGCompare (DataD dataCxt name bndrs cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GCompare) (conT name)) [gcompareDec] gcompareDec = gcompareFunction bndrs cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 deriveGCompare (DataInstD dataCxt name tyArgs cons _) = return <$> inst 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 |] ] ) ) |] ) [] dependent-sum-template-0.0.0.4/src/Data/GADT/Show/0000755000000000000000000000000012556763675017545 5ustar0000000000000000dependent-sum-template-0.0.0.4/src/Data/GADT/Show/TH.hs0000644000000000000000000000540312556763675020416 0ustar0000000000000000{-# 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 deriveGShow (InstanceD cxt (AppT instType dataType) decs) | headOfType instType == ''GShow = do let dataTypeName = headOfType dataType dataTypeInfo <- reify dataTypeName case dataTypeInfo of TyConI (DataD dataCxt name bndrs cons _) -> do gshowDec <- gshowFunction cons return [InstanceD cxt (AppT instType dataType) [gshowDec]] _ -> fail "deriveGShow: the name of an algebraic data type constructor is required" deriveGShow (DataD dataCxt name bndrs cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (appT (conT ''GShow) (conT name)) [gshowDec] gshowDec = gshowFunction cons #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 deriveGShow (DataInstD dataCxt name tyArgs cons _) = return <$> inst 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 ] )) |]