@@ -1,255 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE Rank2Types #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
15−-----------------------------------------------------------------------------
17−-- Module : Data.Generics.Sum.HasConstructor
18−-- Copyright : (C) 2017 Csongor Kiss
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
24−-- Derive prisms generically
31−-- | Baz (Int, String)
33−-- deriving (Show, Generic)
37−-- >>> Bar 5 "coconut" ^? as @"Bar"
38−-- Just (5, "coconut")
40−-- >>> Qux ^? as @"Qux"
43−-- >>> as @"Bar" # (5, "asd") :: FooBar
47−-----------------------------------------------------------------------------
49−module Data.Generics.Sum.HasConstructor
50− ( HasConstructor (..)
53−import Data.Generics.Internal.Lens
55−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
56−import Data.Kind (Type, Constraint)
59−class HasConstructor (con :: Symbol) a s | s con -> a where
64− , ErrorUnless (ContainsC con (Rep s)) con s
65− , GHasConstructor con (Rep s) a
66− ) => HasConstructor con a s where
67− as = repIso . gconstruct @con
69−--------------------------------------------------------------------------------
71−type family ErrorUnless (contains :: Bool) (con :: Symbol) (s :: *) :: Constraint where
72− ErrorUnless 'False con s
73− = TypeError ( 'ShowType s
74− ':<>: 'Text " has no constructor with name "
79−--------------------------------------------------------------------------------
81−data HList (xs :: [Type]) where
83− (:>) :: x -> HList xs -> HList (x ': xs)
87−append :: HList xs -> HList ys -> HList (xs ++ ys)
89−append (x :> xs) ys = x :> (xs `append` ys)
91−class AsList (tup :: *) (xs :: [*]) | xs -> tup where
92− asList :: tup -> HList xs
93− asTuple :: HList xs -> tup
95−instance AsList () '[] where
102−instance AsList a '[a] where
109−instance AsList (a, b) '[a, b] where
113− asTuple (a :> b :> Nil)
116−instance AsList (a, b, c) '[a, b, c] where
118− = a :> b :> c :> Nil
120− asTuple (a :> b :> c :> Nil)
123−instance AsList (a, b, c, d) '[a, b, c, d] where
125− = a :> b :> c :> d :> Nil
127− asTuple (a :> b :> c :> d :> Nil)
130−instance AsList (a, b, c, d, e) '[a, b, c, d, e] where
131− asList (a, b, c, d, e)
132− = a :> b :> c :> d :> e :> Nil
134− asTuple (a :> b :> c :> d :> e :> Nil)
137−instance AsList (a, b, c, d, e, f) '[a, b, c, d, e, f] where
138− asList (a, b, c, d, e, f)
139− = a :> b :> c :> d :> e :> f :> Nil
141− asTuple (a :> b :> c :> d :> e :> f :> Nil)
142− = (a, b, c, d, e, f)
144−instance AsList (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
145− asList (a, b, c, d, e, f, g)
146− = a :> b :> c :> d :> e :> f :> g :> Nil
148− asTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
149− = (a, b, c, d, e, f, g)
151−instance AsList (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
152− asList (a, b, c, d, e, f, g, h)
153− = a :> b :> c :> d :> e :> f :> g :> h :> Nil
155− asTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
156− = (a, b, c, d, e, f, g, h)
158−type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where
160− (x ': xs) ++ ys = x ': xs ++ ys
162−--------------------------------------------------------------------------------
164−class GHasConstructor (con :: Symbol) (s :: Type -> Type) a | con s -> a where
165− gconstruct :: Prism' (s x) a
167−instance GHasConstructor con s a => GHasConstructor con (M1 D c s) a where
168− gconstruct = mIso . gconstruct @con
170−instance (GCollect s xs, AsList a xs) => GHasConstructor con (M1 C ('MetaCons con f n) s) a where
171− gconstruct = prism (M1 . gto . asList) (Right . asTuple @_ @xs . gfrom . unM1)
173−instance (GHasConstructor con s a) => GHasConstructor con (M1 S m s) a where
174− gconstruct = mIso . gconstruct @con
176−class GHasConstructorSum (con :: Symbol) l r a (p :: Bool) | con l r p -> a where
177− gconstructSum :: Prism' ((l :+: r) x) a
179−instance GHasConstructor con l a => GHasConstructorSum con l r a 'True where
180− gconstructSum = left . gconstruct @con
182−instance GHasConstructor con r a => GHasConstructorSum con l r a 'False where
183− gconstructSum = right . gconstruct @con
185−instance GHasConstructorSum con l r a (ContainsC con l) => GHasConstructor con (l :+: r) a where
186− gconstruct = gconstructSum @con @l @r @a @(ContainsC con l)
188−--------------------------------------------------------------------------------
189−-- * Split is the inverse of append
191−class Split xs ys zs | xs ys -> zs, xs zs -> ys where
192− split :: HList zs -> (HList xs, HList ys)
194−instance Split '[] xs xs where
195− split xs = (Nil, xs)
197−instance Split xs ys zs => Split (x ': xs) ys (x ': zs) where
198− split (x :> xs) = (x :> xs', ys')
199− where (xs', ys') = split xs
201−--------------------------------------------------------------------------------
203−-- | Collect parameters of a constructor into an HList
204−class GCollect (s :: Type -> Type) (xs :: [Type]) | s -> xs where
205− gfrom :: s x -> HList xs
206− gto :: HList xs -> s x
213− ) => GCollect (a :*: b) xs where
215− gfrom (a :*: b) = gfrom a `append` gfrom b
216− gto xs = gto l :*: gto r
217− where (l, r) = split @as @bs xs
219−instance GCollect (K1 R a) '[a] where
220− gfrom (K1 x) = x :> Nil
221− gto (x :> Nil) = K1 x
223−instance GCollect U1 '[] where
227−instance GCollect s a => GCollect (M1 S c s) a where
228− gfrom (M1 x) = gfrom x
231−instance GCollect s a => GCollect (M1 D c s) a where
232− gfrom (M1 x) = gfrom x
235−instance GCollect s a => GCollect (M1 C c s) a where
236− gfrom (M1 x) = gfrom x
239−--------------------------------------------------------------------------------
241−type family ContainsC (cname :: Symbol) f :: Bool where
242− ContainsC cname (C1 ('MetaCons cname _ _) _)
244− ContainsC cname (f :+: g)
245− = ContainsC cname f || ContainsC cname g
246− ContainsC cname (D1 m f)
251−-- | Type-level alternative
252−type family (a :: Bool) || (b :: Bool) :: Bool where