git.iko.soy/generic-lens
on bfcd00a help sign in
generic-lens/src/Data/Generics/Sum/Typed.hs
111 lines 2.9 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
12-----------------------------------------------------------------------------
13-- |
14-- Module : Data.Generics.Sum.Typed
15-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
19-- Portability : non-portable
20--
21-- Derive constructor-field-type-based prisms generically.
22--
23-----------------------------------------------------------------------------
25module Data.Generics.Sum.Typed
26 ( -- *Prisms
27 --
28 -- $example
29 AsType (..)
30 ) where
32import Data.Kind
33import GHC.Generics
34import GHC.TypeLits (TypeError, ErrorMessage (..))
35import Data.Generics.Sum.Internal.Typed
37import Data.Generics.Internal.Families
38import Data.Generics.Internal.Lens
40-- $example
41-- @
42-- module Example where
43--
44-- import Data.Generics.Sum
45-- import GHC.Generics
46--
47-- data Animal
48-- = Dog Dog
49-- | Cat Name Age
50-- | Duck Age
51-- deriving (Generic, Show)
52--
53-- data Dog = MkDog
54-- { name :: Name
55-- , age :: Age
56-- }
57-- deriving (Generic, Show)
58--
59-- type Name = String
60-- type Age = Int
61--
62-- dog, cat, duck :: Animal
63--
64-- dog = Dog (MkDog "Shep" 3)
65-- cat = Cat "Mog" 5
66-- duck = Duck 2
67-- @
69-- |Sums that have a constructor with a field of the given type.
70class AsType a s where
71 -- |A prism that projects a constructor uniquely identifiable by the type of
72 -- its field. Compatible with the lens package's 'Control.Lens.Prism' type.
73 --
74 -- >>> dog ^? _Typed @Dog
75 -- Just (MkDog {name = "Shep", age = 3})
76 -- >>> dog ^? _Typed @Age
77 -- Nothing
78 -- >>> cat ^? _Typed @(Name, Age)
79 -- Just ("Mog",5)
80 -- >>> duck ^? _Typed @Age
81 -- Just 2
82 _Typed :: Prism' s a
84instance
85 ( Generic s
86 , ErrorUnlessOne a s (CountPartialType a (Rep s))
87 , GAsType (Rep s) a
88 ) => AsType a s where
90 _Typed = repIso . _GTyped
92type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where
93 ErrorUnlessOne a s 'None
94 = TypeError
95 ( 'Text "The type "
96 ':<>: 'ShowType s
97 ':<>: 'Text " does not contain a constructor whose field is of type "
98 ':<>: 'ShowType a
99 )
101 ErrorUnlessOne a s 'Multiple
102 = TypeError
103 ( 'Text "The type "
104 ':<>: 'ShowType s
105 ':<>: 'Text " contains multiple constructors whose fields are of type "
106 ':<>: 'ShowType a
107 ':<>: 'Text "; the choice of constructor is thus ambiguous"
108 )
110 ErrorUnlessOne _ _ 'One
111 = ()