dependent-sum-template 0.0.0.6 → 0.1.0.0

raw patch · 6 files changed

+154/−157 lines, 6 filesdep +constraints-extrasdep ~dependent-sumnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: constraints-extras

Dependency ranges changed: dependent-sum

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• dependent-sum-template.cabal +15/−2
• src/Data/Dependent/Sum/TH/Internal.hs +48/−0
• src/Data/GADT/Compare/TH.hs +24/−101
• src/Data/GADT/Show/TH.hs +15/−46
• test/test.hs +47/−8

@@ -0,0 +1,5 @@+# Revision history for dependent-sum++## 0.1.0.0 - 2019-03-21++* Remove code for generating instances of *Tag classes, as they were removed in dependent-sum-0.6.

@@ -1,5 +1,5 @@ name:                   dependent-sum-template-version:                0.0.0.6+version:                0.1.0.0 stability:              experimental  cabal-version:          >= 1.8@@ -14,23 +14,36 @@ 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.4++extra-source-files:     ChangeLog.md+ source-repository head   type: git   location: https://github.com/mokus0/dependent-sum-template  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.2 && < 0.5,+                        dependent-sum >= 0.4.1 && < 0.7,                         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

@@ -0,0 +1,48 @@+{-# 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+deriveForDec className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst+    where+        inst = instanceD (cxt (map return dataCxt)) (makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs))) [dec]+        -- TODO: figure out proper number of family parameters vs instance parameters+        bndrs = [PlainTV v | VarT v <- tail tyArgs ]+        dec = f bndrs cons

@@ -3,9 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-}-#endif module Data.GADT.Compare.TH     ( DeriveGEQ(..)     , DeriveGCompare(..)@@ -14,7 +12,12 @@  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 @@ -30,47 +33,7 @@             _ -> 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+    deriveGEq = deriveForDec ''GEq (\t -> [t| GEq $t |]) geqFunction  instance DeriveGEQ t => DeriveGEQ [t] where     deriveGEq [it] = deriveGEq it@@ -79,9 +42,9 @@ instance DeriveGEQ t => DeriveGEQ (Q t) where     deriveGEq = (>>= deriveGEq) -geqFunction bndrs cons = funD 'geq +geqFunction bndrs cons = funD 'geq     (  map (geqClause bndrs) cons-    ++  [ clause [wildP, wildP] (normalB [| Nothing |]) [] +    ++  [ clause [wildP, wildP] (normalB [| Nothing |]) []         | length cons /= 1         ]     )@@ -89,15 +52,15 @@ 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 +        ( normalB $ doE             (  [ if needsGEq argType                     then bindS (conP 'Refl []) [| geq $(varE lArg) $(varE rArg) |]                     else noBindS [| guard ($(varE lArg) == $(varE rArg)) |]@@ -118,9 +81,9 @@     GComparing (Right x) >>= f = f x instance Applicative (GComparing a b) where     pure = return-    (<*>) = ap +    (<*>) = ap -geq' :: GCompare t => t a -> t b -> GComparing x y (a := b)+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@@ -144,47 +107,7 @@             _ -> 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+    deriveGCompare = deriveForDec ''GCompare (\t -> [t| GCompare $t |]) gcompareFunction  instance DeriveGCompare t => DeriveGCompare [t] where     deriveGCompare [it] = deriveGCompare it@@ -197,19 +120,19 @@     | 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 +        -- 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 = +        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 ++        -- 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)@@ -217,16 +140,16 @@             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 +                    [| runGComparing $+                        $(doE                             (  [ if needsGCompare argType con                                     then bindS (conP 'Refl []) [| geq' $(varE lArg) $(varE rArg) |]                                     else noBindS [| compare' $(varE lArg) $(varE rArg) |]

@@ -5,7 +5,11 @@  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@@ -21,46 +25,7 @@             _ -> 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+    deriveGShow = deriveForDec ''GShow (\t -> [t| GShow $t |]) $ \_ -> gshowFunction  instance DeriveGShow t => DeriveGShow [t] where     deriveGShow [it] = deriveGShow it@@ -75,22 +40,26 @@     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)]++    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 = +gshowBody prec conName argNames =     [| showParen ($prec > 10) $( composeExprs $ intersperse [| showChar ' ' |]         ( showsName conName         : [ [| showsPrec 11 $arg |]           | argName <- argNames, let arg = varE argName           ]-        )) +        ))      |]

@@ -1,11 +1,20 @@ {-# 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@@ -15,22 +24,52 @@   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-  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+  polyTests id+  polyTests MyNestedSum_MySum   return ()  --TODO: Figure out how to best use these test cases; just checking that they