Skip to content

Commit 988295f

Browse files
phadejphadej
committed
Add deriveFiniteSome
1 parent d90d54f commit 988295f

File tree

6 files changed

+207
-50
lines changed

6 files changed

+207
-50
lines changed

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
name: universe-dependent-sum
22
version: 1.2.0.1
3+
x-revision: 1
34
synopsis: Universe instances for types from dependent-sum
45
description:
56
A class for finite and recursively enumerable types and some helper functions for enumerating them
@@ -59,4 +60,4 @@ library
5960
, dependent-sum >=0.3.2.2 && <0.8
6061
, some >=1 && <1.1
6162
, universe-base >=1.1 && <1.1.2
62-
, universe-some >=1.2 && <1.3
63+
, universe-some >=1.2 && <1.4

‎universe-some/CHANGELOG.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
# 1.3
2+
3+
- Add 'deriveFiniteSome'

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

Lines changed: 165 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -7,12 +7,14 @@
77
module Data.Universe.Some.TH (
88
DeriveUniverseSome (..),
99
universeSomeQ,
10+
universeFSomeQ,
1011
) where
1112

1213
import Control.Monad (forM, mapM, unless)
13-
import Data.Some (Some, mkSome)
14-
import Data.Universe.Class (Universe (..))
15-
import Data.Universe.Some (UniverseSome (..))
14+
import Data.Some (Some, mkSome, withSomeM)
15+
import Data.Traversable (for)
16+
import Data.Universe.Class (Universe (..), Finite (..))
17+
import Data.Universe.Some (UniverseSome (..), FiniteSome (..))
1618
import Data.Universe.Helpers (interleave, (<+*+>))
1719
import Language.Haskell.TH
1820
import Language.Haskell.TH.Datatype
@@ -41,14 +43,28 @@ import Language.Haskell.TH.Datatype
4143
class DeriveUniverseSome a where
4244
deriveUniverseSome :: a -> DecsQ
4345

46+
-- | 'deriveFiniteSome' derives 'FiniteSome' instance with slightly different
47+
-- code, without interleaving of different branches. This allows to handle
48+
-- more cases.
49+
--
50+
-- It also defines a trivial 'universeSome = universeFSome' 'UniverseSome' instance.
51+
--
52+
deriveFiniteSome :: a -> DecsQ
53+
4454
instance DeriveUniverseSome a => DeriveUniverseSome [a] where
4555
deriveUniverseSome a = fmap concat (mapM deriveUniverseSome a)
56+
deriveFiniteSome a = fmap concat (mapM deriveFiniteSome a)
4657

4758
instance DeriveUniverseSome a => DeriveUniverseSome (Q a) where
4859
deriveUniverseSome a = deriveUniverseSome =<< a
60+
deriveFiniteSome a = deriveFiniteSome =<< a
4961

5062
instance DeriveUniverseSome Name where
51-
deriveUniverseSome name = do
63+
deriveUniverseSome = deriveUniverseSomeName ClsUniverse
64+
deriveFiniteSome = deriveUniverseSomeName ClsFinite
65+
66+
deriveUniverseSomeName :: Cls -> Name -> Q [Dec]
67+
deriveUniverseSomeName cls name = do
5268
di <- reifyDatatype name
5369
let DatatypeInfo { datatypeContext = ctxt
5470
, datatypeName = parentName
@@ -73,40 +89,77 @@ instance DeriveUniverseSome Name where
7389

7490
#if MIN_VERSION_template_haskell(2,10,0)
7591
let constrs :: [TypeQ]
76-
constrs = map (\n -> conT ''Universe `appT` varT n) varNames
92+
constrs = map (\n -> conT clsName `appT` varT n) varNames
7793
#else
7894
let constrs :: [PredQ]
79-
constrs = map (\n -> classP ''Universe [varT n]) varNames
95+
constrs = map (\n -> classP clsName [varT n]) varNames
8096
#endif
8197
let typ = foldl (\c n -> c `appT` varT n) (conT parentName) varNames
8298

83-
i <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)
84-
[ instanceDecFor di
85-
]
99+
case cls of
100+
ClsUniverse -> do
101+
i <- instanceD (cxt constrs) (conT clsSomeName `appT` typ)
102+
[ instanceDecForU di
103+
]
104+
return [i]
105+
ClsFinite -> do
106+
i <- instanceD (cxt constrs) (conT clsSomeName `appT` typ)
107+
[ instanceDecForF di
108+
]
109+
j <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)
110+
[ instanceDecForUviaF
111+
]
112+
return [i, j]
113+
114+
where
115+
clsName = case cls of
116+
ClsUniverse -> ''Universe
117+
ClsFinite -> ''Finite
118+
119+
clsSomeName = case cls of
120+
ClsUniverse -> ''UniverseSome
121+
ClsFinite -> ''FiniteSome
122+
123+
instanceDecForU :: DatatypeInfo -> Q Dec
124+
instanceDecForU di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []
86125

87-
return [i]
126+
instanceDecForF :: DatatypeInfo -> Q Dec
127+
instanceDecForF di = valD (varP 'universeFSome) (normalB $ universeFSomeQ' di) []
88128

89-
instanceDecFor :: DatatypeInfo -> Q Dec
90-
instanceDecFor di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []
129+
instanceDecForUviaF :: Q Dec
130+
instanceDecForUviaF = valD (varP 'universeSome) (normalB $ varE 'universeFSome) []
91131

92132
instance DeriveUniverseSome Dec where
133+
deriveUniverseSome = deriveUniverseSomeDec ClsUniverse
134+
deriveFiniteSome = deriveUniverseSomeDec ClsFinite
135+
136+
deriveUniverseSomeDec :: Cls -> Dec -> Q [Dec]
93137
#if MIN_VERSION_template_haskell(2,11,0)
94-
deriveUniverseSome (InstanceD overlaps c classHead []) = do
95-
let instanceFor = InstanceD overlaps c classHead
138+
deriveUniverseSomeDec cls (InstanceD overlaps c classHead []) = do
139+
let instanceFor = fmap (InstanceD overlaps c classHead) . sequence
140+
let instanceForU = fmap (InstanceD overlaps c (overHeadOfType (const ''UniverseSome) classHead)) . sequence
96141
#else
97-
deriveUniverseSome (InstanceD c classHead []) = do
98-
let instanceFor = InstanceD c classHead
142+
deriveUniverseSomeDec cls (InstanceD c classHead []) = do
143+
let instanceFor = fmap (InstanceD c classHead) . sequence
144+
let instanceForU = fmap (InstanceD c (overHeadOfType (const ''UniverseSome) classHead)) . sequence
99145
#endif
100146
case classHead of
101-
ConT u `AppT` t | u == ''UniverseSome -> do
102-
name <- headOfType t
103-
di <- reifyDatatype name
104-
i <- fmap instanceFor $ mapM id
105-
[ instanceDecFor di
106-
]
107-
return [i]
108-
_ -> fail $ "deriveUniverseSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead
109-
deriveUniverseSome _ = fail "deriveUniverseSome: expected an empty instance declaration"
147+
ConT u `AppT` t
148+
| cls == ClsUniverse
149+
, u == ''UniverseSome -> do
150+
name <- headOfType t
151+
di <- reifyDatatype name
152+
i <- instanceFor [ instanceDecForU di ]
153+
return [i]
154+
| cls == ClsFinite
155+
, u == ''FiniteSome -> do
156+
name <- headOfType t
157+
di <- reifyDatatype name
158+
i <- instanceFor [ instanceDecForF di ]
159+
j <- instanceForU [ instanceDecForUviaF ]
160+
return [i, j]
161+
_ -> fail $ "deriveUniverseSome/deriveFiniteSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead
162+
deriveUniverseSomeDec _ _ = fail "deriveUniverseSome/deriveFiniteSome: expected an empty instance declaration"
110163

111164
-- | Derive the method for @:: ['Some' tag]@
112165
--
@@ -123,6 +176,32 @@ instance DeriveUniverseSome Dec where
123176
universeSomeQ :: Name -> ExpQ
124177
universeSomeQ name = reifyDatatype name >>= universeSomeQ'
125178

179+
-- | Like 'universeSomeQ' but derives expression for 'universeF'.
180+
--
181+
-- Uses the fact that subterms should be finite,
182+
-- thus allowing to derive more instances.
183+
--
184+
-- >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving
185+
-- >>> import Data.GADT.Show
186+
--
187+
-- >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool
188+
-- >>> deriving instance Show b => Show (Tag b a)
189+
-- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec
190+
-- >>> $(deriveFiniteSome ''Tag);
191+
--
192+
-- >>> universeFSome :: [Some (Tag Bool)]
193+
-- [Some IntTag,Some (BoolTag False),Some (BoolTag True)]
194+
--
195+
-- >>> data Wrap a where Once :: Tag Bool a -> Wrap a; Empty :: Wrap ()
196+
-- >>> deriving instance Show (Wrap a)
197+
-- >>> instance GShow Wrap where gshowsPrec = showsPrec
198+
--
199+
-- >>> $(universeFSomeQ ''Wrap) :: [Some Wrap]
200+
-- [Some (Once IntTag),Some (Once (BoolTag False)),Some (Once (BoolTag True)),Some Empty]
201+
--
202+
universeFSomeQ :: Name -> ExpQ
203+
universeFSomeQ name = reifyDatatype name >>= universeFSomeQ'
204+
126205
universeSomeQ' :: DatatypeInfo -> Q Exp
127206
universeSomeQ' di = do
128207
let DatatypeInfo { datatypeContext = ctxt
@@ -141,20 +220,65 @@ universeSomeQ' di = do
141220
case safeUnsnoc vars0 of
142221
Nothing -> fail "Datatype should have at least one type variable"
143222
Just (vars, var) -> do
144-
let universe' = [| universe |]
145-
let uap = [| (<+*+>) |]
146-
let interleave' = [| interleave |]
147-
let mapSome' = [| map mkSome |]
148-
149-
let sums = map (universeForCon mapSome' universe' uap) cons
223+
let sums = map universeForCon cons
150224
interleave' `appE` listE sums
151225
where
152-
universeForCon mapSome' universe' uap ci =
226+
universeForCon ci = do
153227
let con = listE [ conE (constructorName ci) ]
154228
nargs = length (constructorFields ci)
155229
conArgs = foldl (\f x -> infixE (Just f) uap (Just universe')) con (replicate nargs universe')
230+
mapSome' `appE` conArgs
231+
232+
universe' = [| universe |]
233+
uap = [| (<+*+>) |]
234+
interleave' = [| interleave |]
235+
mapSome' = [| map mkSome |]
156236

157-
in mapSome' `appE` conArgs
237+
universeFSomeQ' :: DatatypeInfo -> Q Exp
238+
universeFSomeQ' di = do
239+
let DatatypeInfo { datatypeContext = ctxt
240+
, datatypeName = parentName
241+
#if MIN_VERSION_th_abstraction(0,3,0)
242+
, datatypeInstTypes = vars0
243+
#else
244+
, datatypeVars = vars0
245+
#endif
246+
, datatypeCons = cons
247+
} = di
248+
249+
-- check
250+
unless (null ctxt) $ fail "Datatype context is not empty"
251+
252+
case safeUnsnoc vars0 of
253+
Nothing -> fail "Datatype should have at least one type variable"
254+
Just (vars, var) -> do
255+
let sums = map universeForCon cons
256+
[| concat |] `appE` listE sums
257+
where
258+
universeForCon ci = do
259+
let con = conE (constructorName ci)
260+
args <- forM (zip [1..] (constructorFields ci)) $ \(j, f) -> do
261+
name <- newName ("x" ++ show (j :: Int))
262+
let defStep kont = infixE (Just universeF') [| (>>=) |] (Just (lamE [varP name] kont))
263+
return $ (,) (varE name) $ \kont -> case f of
264+
AppT c _ -> do
265+
#if MIN_VERSION_template_haskell(2,6,0)
266+
isInst <- isInstance ''FiniteSome [c]
267+
#else
268+
isInst <- isClassInstance ''FiniteSome [c]
269+
#endif
270+
if isInst
271+
then [| withSomeM |] `appE` [| universeFSome |] `appE` (lamE [varP name] kont)
272+
else defStep kont
273+
_ -> defStep kont
274+
275+
foldl (\acc (_, kont) -> kont acc)
276+
(listE [([| mkSome |] `appE` (foldl appE con (map fst args)))])
277+
args
278+
279+
universeF' = [| universeF |]
280+
universeFSome' = [| universeFSome |]
281+
mapSome' = [| map mkSome |]
158282

159283
-------------------------------------------------------------------------------
160284
-- helpers
@@ -166,7 +290,15 @@ headOfType (VarT n) = return n
166290
headOfType (ConT n) = return n
167291
headOfType t = fail $ "headOfType: " ++ show t
168292

293+
overHeadOfType :: (Name -> Name) -> Type -> Type
294+
overHeadOfType f (AppT x y) = AppT (overHeadOfType f x) y
295+
overHeadOfType f (VarT n) = VarT (f n)
296+
overHeadOfType f (ConT n) = ConT (f n)
297+
overHeadOfType f t = t
298+
169299
safeUnsnoc :: [a] -> Maybe ([a], a)
170300
safeUnsnoc xs = case reverse xs of
171301
[] -> Nothing
172302
(y:ys) -> Just (reverse ys, y)
303+
304+
data Cls = ClsUniverse | ClsFinite deriving (Eq)

‎universe-some/test/Test.hs‎

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
{-# LANGUAGE TemplateHaskell #-}
44
module Main (main) where
55

6-
import Data.Universe.Class (Universe (..))
6+
import Data.Universe.Class (Universe (..), Finite (..))
77
import Data.Some (Some (..))
88
import Data.GADT.Show
99
import Data.Universe.Some (UniverseSome (..))
@@ -53,6 +53,23 @@ $(return [])
5353
instance Universe b => UniverseSome (Tag3 b) where
5454
universeSome = $(universeSomeQ ''Tag3)
5555

56+
-------------------------------------------------------------------------------
57+
-- Issue 53
58+
-------------------------------------------------------------------------------
59+
60+
data Foo a where
61+
MkFoo :: Foo Int
62+
data Bar a where
63+
MkBar :: Bool -> Foo a -> Bar a
64+
65+
deriving instance Show (Foo a)
66+
deriving instance Show (Bar a)
67+
instance GShow Foo where gshowsPrec = showsPrec
68+
instance GShow Bar where gshowsPrec = showsPrec
69+
70+
deriveFiniteSome ''Foo
71+
deriveFiniteSome ''Bar
72+
5673
-------------------------------------------------------------------------------
5774
-- Main
5875
-------------------------------------------------------------------------------
@@ -62,3 +79,6 @@ main = do
6279
print (universe :: [Some (Tag (Maybe Bool)) ])
6380
print (universe :: [Some (Tag2 (Maybe Bool)) ])
6481
print (universe :: [Some (Tag3 (Maybe Bool)) ])
82+
83+
print (universeF :: [Some Foo])
84+
print (universeF :: [Some Bar])

‎universe-some/universe-some.cabal‎

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,6 @@
1-
name: universe-some
2-
version: 1.2
3-
x-revision: 1
4-
synopsis: Universe instances for Some from some
1+
name: universe-some
2+
version: 1.3
3+
synopsis: Universe instances for Some from some
54
description:
65
A class for finite and recursively enumerable types and some helper functions for enumerating them
76
defined in @universe-base@ package:
@@ -20,15 +19,16 @@ description:
2019
.
2120
classes.
2221

23-
homepage: https://github.com/dmwit/universe
24-
license: BSD3
25-
license-file: LICENSE
26-
author: Daniel Wagner, Oleg Grenrus
27-
maintainer: me@dmwit.com
28-
copyright: Daniel Wagner 2014, Oleg Grenrus 2019
29-
category: Data
30-
build-type: Simple
31-
cabal-version: >=1.10
22+
homepage: https://github.com/dmwit/universe
23+
license: BSD3
24+
license-file: LICENSE
25+
author: Daniel Wagner, Oleg Grenrus
26+
maintainer: me@dmwit.com
27+
copyright: Daniel Wagner 2014, Oleg Grenrus 2019
28+
category: Data
29+
build-type: Simple
30+
cabal-version: >=1.10
31+
extra-source-files: CHANGELOG.md
3232
tested-with:
3333
GHC ==7.0.4
3434
|| ==7.4.2
@@ -60,7 +60,7 @@ library
6060

6161
build-depends:
6262
base >=4.3 && <4.15
63-
, some >=1 && <1.1
63+
, some >=1.0.1 && <1.1
6464
, template-haskell >=2.5 && <2.17
6565
, th-abstraction >=0.2.11.0 && <0.4
6666
, transformers >=0.3.0.0 && <0.6

‎universe/universe.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
name: universe
22
version: 1.2
3+
x-revision: 1
34
synopsis: A class for finite and recursively enumerable types.
45
description:
56
A class for finite and recursively enumerable types and some helper functions for enumerating them
@@ -54,4 +55,4 @@ library
5455
universe-base >=1.1 && <1.1.2
5556
, universe-instances-extended >=1.1.1 && <1.1.2
5657
, universe-reverse-instances >=1.1 && <1.1.1
57-
, universe-some >=1.2 && <1.2.1
58+
, universe-some >=1.2 && <1.3.1

0 commit comments

Comments
 (0)