Add deriveFiniteSome

universe-dependent-sum/universe-dependent-sum.cabal

@@ -1,5 +1,6 @@
 name:          universe-dependent-sum
 version:       1.2.0.1
+x-revision:    1
 synopsis:      Universe instances for types from dependent-sum
 description:
   A class for finite and recursively enumerable types and some helper functions for enumerating them
@@ -59,4 +60,4 @@ library
     , dependent-sum  >=0.3.2.2 && <0.8
     , some           >=1       && <1.1
     , universe-base  >=1.1     && <1.1.2
-    , universe-some  >=1.2     && <1.3
+    , universe-some  >=1.2     && <1.4

universe-some/CHANGELOG.md

@@ -0,0 +1,3 @@
+# 1.3
+
+- Add 'deriveFiniteSome'

universe-some/src/Data/Universe/Some/TH.hs

@@ -7,12 +7,14 @@
 module Data.Universe.Some.TH (
   DeriveUniverseSome (..),
   universeSomeQ,
+  universeFSomeQ,
   ) where
 
 import Control.Monad (forM, mapM, unless)
-import Data.Some (Some, mkSome)
-import Data.Universe.Class (Universe (..))
-import Data.Universe.Some (UniverseSome (..))
+import Data.Some (Some, mkSome, withSomeM)
+import Data.Traversable (for)
+import Data.Universe.Class (Universe (..), Finite (..))
+import Data.Universe.Some (UniverseSome (..), FiniteSome (..))
 import Data.Universe.Helpers (interleave, (<+*+>))
 import Language.Haskell.TH
 import Language.Haskell.TH.Datatype
@@ -41,14 +43,28 @@ import Language.Haskell.TH.Datatype
 class DeriveUniverseSome a where
   deriveUniverseSome :: a -> DecsQ
 
+  -- | 'deriveFiniteSome' derives 'FiniteSome' instance with slightly different
+  -- code, without interleaving of different branches.  This allows to handle
+  -- more cases.
+  --
+  -- It also defines a trivial 'universeSome = universeFSome' 'UniverseSome' instance.
+  --
+  deriveFiniteSome   :: a -> DecsQ
+
 instance DeriveUniverseSome a => DeriveUniverseSome [a] where
   deriveUniverseSome a = fmap concat (mapM deriveUniverseSome a)
+  deriveFiniteSome   a = fmap concat (mapM deriveFiniteSome a)
 
 instance DeriveUniverseSome a => DeriveUniverseSome (Q a) where
   deriveUniverseSome a = deriveUniverseSome =<< a
+  deriveFiniteSome   a = deriveFiniteSome   =<< a
 
 instance DeriveUniverseSome Name where
-  deriveUniverseSome name = do
+  deriveUniverseSome = deriveUniverseSomeName ClsUniverse
+  deriveFiniteSome   = deriveUniverseSomeName ClsFinite
+
+deriveUniverseSomeName :: Cls -> Name -> Q [Dec]
+deriveUniverseSomeName cls name = do
     di <- reifyDatatype name
     let DatatypeInfo { datatypeContext = ctxt
                      , datatypeName    = parentName
@@ -73,40 +89,77 @@ instance DeriveUniverseSome Name where
 
 #if MIN_VERSION_template_haskell(2,10,0)
         let constrs :: [TypeQ]
-            constrs = map (\n -> conT ''Universe `appT` varT n) varNames
+            constrs = map (\n -> conT clsName `appT` varT n) varNames
 #else
         let constrs :: [PredQ]
-            constrs = map (\n -> classP ''Universe [varT n]) varNames
+            constrs = map (\n -> classP clsName [varT n]) varNames
 #endif
         let typ     = foldl (\c n -> c `appT` varT n) (conT parentName) varNames
 
-        i <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)
-            [ instanceDecFor di
-            ]
+        case cls of
+          ClsUniverse -> do
+            i <- instanceD (cxt constrs) (conT clsSomeName `appT` typ)
+                [ instanceDecForU di
+                ]
+            return [i]
+          ClsFinite -> do
+            i <- instanceD (cxt constrs) (conT clsSomeName `appT` typ)
+                [ instanceDecForF di
+                ]
+            j <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)
+                [ instanceDecForUviaF
+                ]
+            return [i, j]
+
+  where
+    clsName = case cls of
+      ClsUniverse -> ''Universe
+      ClsFinite   -> ''Finite
+
+    clsSomeName = case cls of
+      ClsUniverse -> ''UniverseSome
+      ClsFinite   -> ''FiniteSome
+
+instanceDecForU :: DatatypeInfo -> Q Dec
+instanceDecForU di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []
 
-        return [i]
+instanceDecForF :: DatatypeInfo -> Q Dec
+instanceDecForF di = valD (varP 'universeFSome) (normalB $ universeFSomeQ' di) []
 
-instanceDecFor :: DatatypeInfo -> Q Dec
-instanceDecFor di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []
+instanceDecForUviaF :: Q Dec
+instanceDecForUviaF = valD (varP 'universeSome) (normalB $ varE 'universeFSome) []
 
 instance DeriveUniverseSome Dec where
+  deriveUniverseSome = deriveUniverseSomeDec ClsUniverse
+  deriveFiniteSome   = deriveUniverseSomeDec ClsFinite
+
+deriveUniverseSomeDec :: Cls -> Dec -> Q [Dec]
 #if MIN_VERSION_template_haskell(2,11,0)
-  deriveUniverseSome (InstanceD overlaps c classHead []) = do
-    let instanceFor = InstanceD overlaps c classHead
+deriveUniverseSomeDec cls (InstanceD overlaps c classHead []) = do
+    let instanceFor  = fmap (InstanceD overlaps c classHead) . sequence
+    let instanceForU = fmap (InstanceD overlaps c (overHeadOfType (const ''UniverseSome) classHead)) . sequence
 #else
-  deriveUniverseSome (InstanceD c classHead []) = do
-    let instanceFor = InstanceD c classHead
+deriveUniverseSomeDec cls (InstanceD c classHead []) = do
+    let instanceFor  = fmap (InstanceD c classHead) . sequence
+    let instanceForU = fmap (InstanceD c (overHeadOfType (const ''UniverseSome) classHead)) . sequence
 #endif
     case classHead of
-      ConT u `AppT` t | u == ''UniverseSome -> do
-        name <- headOfType t
-        di <- reifyDatatype name
-        i <- fmap instanceFor $ mapM id
-            [ instanceDecFor di
-            ]
-        return [i]
-      _ -> fail $ "deriveUniverseSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead
-  deriveUniverseSome _ = fail "deriveUniverseSome: expected an empty instance declaration"
+      ConT u `AppT` t
+        | cls == ClsUniverse
+        , u == ''UniverseSome -> do
+          name <- headOfType t
+          di <- reifyDatatype name
+          i <- instanceFor [ instanceDecForU di ]
+          return [i]
+        | cls == ClsFinite
+        , u == ''FiniteSome -> do
+          name <- headOfType t
+          di <- reifyDatatype name
+          i <- instanceFor [ instanceDecForF di ]
+          j <- instanceForU [ instanceDecForUviaF ]
+          return [i, j]
+      _ -> fail $ "deriveUniverseSome/deriveFiniteSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead
+deriveUniverseSomeDec _ _ = fail "deriveUniverseSome/deriveFiniteSome: expected an empty instance declaration"
 
 -- | Derive the method for @:: ['Some' tag]@
 --
@@ -123,6 +176,32 @@ instance DeriveUniverseSome Dec where
 universeSomeQ :: Name -> ExpQ
 universeSomeQ name = reifyDatatype name >>= universeSomeQ'
 
+-- | Like 'universeSomeQ' but derives expression for 'universeF'.
+--
+-- Uses the fact that subterms should be finite,
+-- thus allowing to derive more instances.
+--
+-- >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving
+-- >>> import Data.GADT.Show
+--
+-- >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool
+-- >>> deriving instance Show b => Show (Tag b a)
+-- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec
+-- >>> $(deriveFiniteSome ''Tag);
+--
+-- >>> universeFSome :: [Some (Tag Bool)]
+-- [Some IntTag,Some (BoolTag False),Some (BoolTag True)]
+--
+-- >>> data Wrap a where Once :: Tag Bool a -> Wrap a; Empty :: Wrap ()
+-- >>> deriving instance Show (Wrap a)
+-- >>> instance GShow Wrap where gshowsPrec = showsPrec
+--
+-- >>> $(universeFSomeQ ''Wrap) :: [Some Wrap]
+-- [Some (Once IntTag),Some (Once (BoolTag False)),Some (Once (BoolTag True)),Some Empty]
+--
+universeFSomeQ :: Name -> ExpQ
+universeFSomeQ name = reifyDatatype name >>= universeFSomeQ'
+
 universeSomeQ' :: DatatypeInfo -> Q Exp
 universeSomeQ' di = do
   let DatatypeInfo { datatypeContext = ctxt
@@ -141,20 +220,65 @@ universeSomeQ' di = do
   case safeUnsnoc vars0 of
     Nothing -> fail "Datatype should have at least one type variable"
     Just (vars, var) -> do
-      let universe'   = [| universe |]
-      let uap         = [| (<+*+>) |]
-      let interleave' = [| interleave |]
-      let mapSome'    = [| map mkSome |]
-
-      let sums = map (universeForCon mapSome' universe' uap) cons
+      let sums = map universeForCon cons
       interleave' `appE` listE sums
   where
-    universeForCon mapSome' universe' uap ci =
+    universeForCon ci = do
       let con     = listE [ conE (constructorName ci) ]
           nargs   = length (constructorFields ci)
           conArgs = foldl (\f x -> infixE (Just f) uap (Just universe')) con (replicate nargs universe')
+      mapSome' `appE` conArgs
+
+    universe'   = [| universe |]
+    uap         = [| (<+*+>) |]
+    interleave' = [| interleave |]
+    mapSome'    = [| map mkSome |]
 
-      in mapSome' `appE` conArgs
+universeFSomeQ' :: DatatypeInfo -> Q Exp
+universeFSomeQ' di = do
+  let DatatypeInfo { datatypeContext = ctxt
+                   , datatypeName    = parentName
+#if MIN_VERSION_th_abstraction(0,3,0)
+                   , datatypeInstTypes = vars0
+#else
+                   , datatypeVars    = vars0
+#endif
+                   , datatypeCons    = cons
+                   } = di
+
+  -- check
+  unless (null ctxt) $ fail "Datatype context is not empty"
+
+  case safeUnsnoc vars0 of
+    Nothing -> fail "Datatype should have at least one type variable"
+    Just (vars, var) -> do
+      let sums = map universeForCon cons
+      [| concat |] `appE` listE sums
+  where
+    universeForCon ci = do
+      let con     = conE (constructorName ci)
+      args <- forM (zip [1..] (constructorFields ci)) $ \(j, f) -> do
+        name <- newName ("x" ++ show (j :: Int))
+        let defStep kont = infixE (Just universeF') [| (>>=) |] (Just (lamE [varP name] kont))
+        return $ (,) (varE name) $ \kont -> case f of
+          AppT c _ -> do
+#if MIN_VERSION_template_haskell(2,6,0)
+            isInst <- isInstance ''FiniteSome [c]
+#else
+            isInst <- isClassInstance ''FiniteSome [c]
+#endif
+            if isInst
+            then [| withSomeM |] `appE` [| universeFSome |] `appE` (lamE [varP name] kont)
+            else defStep kont
+          _ -> defStep kont
+
+      foldl (\acc (_, kont) -> kont acc)
+            (listE [([| mkSome |] `appE` (foldl appE con (map fst args)))])
+            args
+
+    universeF'     = [| universeF |]
+    universeFSome' = [| universeFSome |]
+    mapSome'       = [| map mkSome |]
 
 -------------------------------------------------------------------------------
 -- helpers
@@ -166,7 +290,15 @@ headOfType (VarT n)   = return n
 headOfType (ConT n)   = return n
 headOfType t          = fail $ "headOfType: " ++ show t
 
+overHeadOfType :: (Name -> Name) -> Type -> Type
+overHeadOfType f (AppT x y) = AppT (overHeadOfType f x) y
+overHeadOfType f (VarT n)   = VarT (f n)
+overHeadOfType f (ConT n)   = ConT (f n)
+overHeadOfType f t          = t
+
 safeUnsnoc :: [a] -> Maybe ([a], a)
 safeUnsnoc xs = case reverse xs of
   []     -> Nothing
   (y:ys) -> Just (reverse ys, y)
+
+data Cls = ClsUniverse | ClsFinite deriving (Eq)

universe-some/test/Test.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Main (main) where
 
-import Data.Universe.Class (Universe (..))
+import Data.Universe.Class (Universe (..), Finite (..))
 import Data.Some (Some (..))
 import Data.GADT.Show
 import Data.Universe.Some (UniverseSome (..))
@@ -53,6 +53,23 @@ $(return [])
 instance Universe b => UniverseSome (Tag3 b) where
     universeSome = $(universeSomeQ ''Tag3)
 
+-------------------------------------------------------------------------------
+-- Issue 53
+-------------------------------------------------------------------------------
+
+data Foo a where
+  MkFoo :: Foo Int
+data Bar a where
+  MkBar :: Bool -> Foo a -> Bar a
+
+deriving instance Show (Foo a)
+deriving instance Show (Bar a)
+instance GShow Foo where gshowsPrec = showsPrec
+instance GShow Bar where gshowsPrec = showsPrec
+
+deriveFiniteSome ''Foo
+deriveFiniteSome ''Bar
+
 -------------------------------------------------------------------------------
 -- Main
 -------------------------------------------------------------------------------
@@ -62,3 +79,6 @@ main = do
   print (universe :: [Some (Tag (Maybe Bool)) ])
   print (universe :: [Some (Tag2 (Maybe Bool)) ])
   print (universe :: [Some (Tag3 (Maybe Bool)) ])
+
+  print (universeF :: [Some Foo])
+  print (universeF :: [Some Bar])

universe-some/universe-some.cabal

@@ -1,7 +1,6 @@
-name:          universe-some
-version:       1.2
-x-revision:    1
-synopsis:      Universe instances for Some from some
+name:               universe-some
+version:            1.3
+synopsis:           Universe instances for Some from some
 description:
   A class for finite and recursively enumerable types and some helper functions for enumerating them
   defined in @universe-base@ package:
@@ -20,15 +19,16 @@ description:
   .
   classes.
 
-homepage:      https://github.com/dmwit/universe
-license:       BSD3
-license-file:  LICENSE
-author:        Daniel Wagner, Oleg Grenrus
-maintainer:    me@dmwit.com
-copyright:     Daniel Wagner 2014, Oleg Grenrus 2019
-category:      Data
-build-type:    Simple
-cabal-version: >=1.10
+homepage:           https://github.com/dmwit/universe
+license:            BSD3
+license-file:       LICENSE
+author:             Daniel Wagner, Oleg Grenrus
+maintainer:         me@dmwit.com
+copyright:          Daniel Wagner 2014, Oleg Grenrus 2019
+category:           Data
+build-type:         Simple
+cabal-version:      >=1.10
+extra-source-files: CHANGELOG.md
 tested-with:
   GHC ==7.0.4
    || ==7.4.2
@@ -60,7 +60,7 @@ library
 
   build-depends:
       base              >=4.3      && <4.15
-    , some              >=1        && <1.1
+    , some              >=1.0.1    && <1.1
     , template-haskell  >=2.5      && <2.17
     , th-abstraction    >=0.2.11.0 && <0.4
     , transformers      >=0.3.0.0  && <0.6

universe/universe.cabal

@@ -1,5 +1,6 @@
 name:               universe
 version:            1.2
+x-revision:         1
 synopsis:           A class for finite and recursively enumerable types.
 description:
   A class for finite and recursively enumerable types and some helper functions for enumerating them
@@ -54,4 +55,4 @@ library
       universe-base                >=1.1   && <1.1.2
     , universe-instances-extended  >=1.1.1 && <1.1.2
     , universe-reverse-instances   >=1.1   && <1.1.1
-    , universe-some                >=1.2   && <1.2.1
+    , universe-some                >=1.2   && <1.3.1