git.iko.soy/generic-lens
on bfcd00a help sign in
generic-lens/src/Data/Generics/Sum/Constructors.hs
106 lines 2.8 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.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.Constructors
27 ( -- *Prisms
29 -- $example
30 AsConstructor (..)
31 ) where
33import Data.Generics.Internal.Families
34import Data.Generics.Internal.Lens
35import Data.Generics.Sum.Internal.Constructors
37import Data.Kind (Constraint, Type)
38import GHC.Generics (Generic (Rep))
39import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41-- $example
42-- @
43-- module Example where
44--
45-- import Data.Generics.Sum
46-- import GHC.Generics
47--
48-- data Animal
49-- = Dog Dog
50-- | Cat Name Age
51-- | Duck Age
52-- deriving (Generic, Show)
53--
54-- data Dog = MkDog
55-- { name :: Name
56-- , age :: Age
57-- }
58-- deriving (Generic, Show)
59--
60-- type Name = String
61-- type Age = Int
62--
63-- dog, cat, duck :: Animal
64--
65-- dog = Dog (MkDog "Shep" 3)
66-- cat = Cat "Mog" 5
67-- duck = Duck 2
68-- @
70-- |Sums that have a constructor with a given name.
71class AsConstructor (ctor :: Symbol) a s | s ctor -> a where
72 -- |A prism that projects a named constructor from a sum. Compatible with the
73 -- lens package's 'Control.Lens.Prism' type.
74 --
75 -- >>> dog ^? _Ctor @"Dog"
76 -- Just (MkDog {name = "Shep", age = 3})
77 --
78 -- >>> dog ^? _Ctor @"Cat"
79 -- Nothing
80 --
81 -- >>> cat ^? _Ctor @"Cat"
82 -- Just ("Mog", 5)
83 --
84 -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
85 -- Cat ("Garfield", 6)
86 _Ctor :: Prism' s a
88instance
89 ( Generic s
90 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
91 , GAsConstructor ctor (Rep s) a
92 ) => AsConstructor ctor a s where
94 _Ctor = repIso . _GCtor @ctor
96type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
97 ErrorUnless ctor s 'False
98 = TypeError
99 ( 'Text "The type "
100 ':<>: 'ShowType s
101 ':<>: 'Text " does not contain a constructor named "
102 ':<>: 'ShowType ctor
103 )
105 ErrorUnless _ _ 'True
106 = ()