diff --git a/universe-dependent-sum/universe-dependent-sum.cabal b/universe-dependent-sum/universe-dependent-sum.cabal index d86c851..de7a5cf 100644 --- a/universe-dependent-sum/universe-dependent-sum.cabal +++ b/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 diff --git a/universe-some/CHANGELOG.md b/universe-some/CHANGELOG.md new file mode 100644 index 0000000..b698d37 --- /dev/null +++ b/universe-some/CHANGELOG.md @@ -0,0 +1,3 @@ +# 1.3 + +- Add 'deriveFiniteSome' diff --git a/universe-some/src/Data/Universe/Some/TH.hs b/universe-some/src/Data/Universe/Some/TH.hs index a8f475f..ab0440d 100644 --- a/universe-some/src/Data/Universe/Some/TH.hs +++ b/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) diff --git a/universe-some/test/Test.hs b/universe-some/test/Test.hs index fe8cf41..99bf653 100644 --- a/universe-some/test/Test.hs +++ b/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]) diff --git a/universe-some/universe-some.cabal b/universe-some/universe-some.cabal index 8a531bd..846a817 100644 --- a/universe-some/universe-some.cabal +++ b/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 diff --git a/universe/universe.cabal b/universe/universe.cabal index d25a90f..549c182 100644 --- a/universe/universe.cabal +++ b/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