git.iko.soy/generic-lens
on bfcd00a help sign in
generic-lens/src/Data/Generics/Sum/Internal/Constructors.hs
63 lines 2.2 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
13-----------------------------------------------------------------------------
14-- |
15-- Module : Data.Generics.Sum.Internal.Constructors
16-- Copyright : (C) 2017 Csongor Kiss
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
20-- Portability : non-portable
21--
22-- Derive constructor-name-based prisms generically.
23--
24-----------------------------------------------------------------------------
26module Data.Generics.Sum.Internal.Constructors
27 ( GAsConstructor (..)
28 ) where
30import Data.Generics.Internal.Families
31import Data.Generics.Internal.HList
32import Data.Generics.Internal.Lens
34import Data.Kind (Type)
35import GHC.Generics
36import GHC.TypeLits (Symbol)
38-- |As 'AsConstructor' but over generic representations as defined by
39-- "GHC.Generics".
40class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where
41 _GCtor :: Prism' (f x) a
43instance
44 ( GCollectible f as
45 , ListTuple a as
46 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where
48 _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)
50instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where
51 _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)
53instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where
54 _GCtor = mIso . _GCtor @ctor
56class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where
57 _GSumCtor :: Prism' ((l :+: r) x) a
59instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where
60 _GSumCtor = left . _GCtor @ctor
62instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where
63 _GSumCtor = right . _GCtor @ctor