git.iko.soy/jrec
on master help sign in
jrec/src/JRec.hs
172 lines 4.9 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE PatternSynonyms #-}
4{-# LANGUAGE TypeApplications #-}
6module JRec
7 ( unField,
8 (:=) (..),
9 Rec,
10 pattern Rec,
11 append,
12 union,
13 insert,
14 insertOrSet,
15 )
16where
18import Control.Lens (coerced, (&), (.~), (^.))
19import qualified "generic-lens" Data.Generics.Product.Fields as GL
20import qualified "generic-optics" Data.Generics.Product.Fields as GO
21import qualified "generic-lens" Data.Generics.Wrapped as GL
22import qualified "generic-optics" Data.Generics.Wrapped as GO
23import Data.Proxy
24import GHC.Exts (Any)
25import GHC.Generics
26import GHC.OverloadedLabels
27import GHC.TypeLits
28import Generic.Data
29import JRec.Field
30import JRec.Internal (Rec, (:=) (..))
31import qualified JRec.Internal as R
32import JRec.Tuple
33import Unsafe.Coerce
35----------------------------------------------------------------------------
36-- unField
37----------------------------------------------------------------------------
39unField :: field ~ field' => R.FldProxy field -> (field' R.:= value) -> value
40unField _ (_ R.:= value) = value
42----------------------------------------------------------------------------
43-- Other operations
44----------------------------------------------------------------------------
46-- Appends records, without removing duplicates.
47--
48-- O(n + m) type check complexity.
49--
50-- FIXME: See spec for a bug when there are duplicates.
51append ::
52 forall lhs rhs res.
53 res ~ R.RecAppend lhs rhs =>
54 Rec lhs ->
55 Rec rhs ->
56 Rec res
57append = R.combine
59-- Merges records, removing duplicates
60--
61-- Left-biased. Does not sort.
62--
63-- O(n * m) type check complexity.
64union ::
65 forall lhs rhs res.
66 ( KnownNat (R.RecSize lhs),
67 KnownNat (R.RecSize rhs),
68 KnownNat (R.RecSize res),
69 res ~ R.Union lhs rhs,
70 R.RecCopy lhs lhs res,
71 R.RecCopy rhs rhs res
72 ) =>
73 Rec lhs ->
74 Rec rhs ->
75 Rec res
76union = R.union
78-- | Insert a field into a record that does not already contain it
79--
80-- O(n) type check complexity.
81insert ::
82 forall label value lts res.
83 ( KnownNat (1 + R.RecSize lts),
84 KnownNat (R.RecSize lts),
85 KnownSymbol label,
86 R.RecCopy lts lts res,
87 res ~ ((label := value) : lts),
88 R.RemoveAccessTo label lts ~ lts
89 ) =>
90 label := value ->
91 Rec lts ->
92 Rec res
93insert = R.combine . Rec
95-- | Insert a field into a record. Set it if it already exists
96--
97-- O(n) type check complexity.
98insertOrSet ::
99 forall label value rhs res.
100 ( KnownNat (R.RecSize rhs),
101 KnownNat (R.RecSize res),
102 KnownNat (R.RecTyIdxH 0 label res),
103 KnownSymbol label,
104 value ~ R.RecTy label res,
105 R.Reverse (R.Insert (label := value) (R.Reverse rhs)) ~ res,
106 R.RecCopy rhs rhs res
107 ) =>
108 label := value ->
109 Rec rhs ->
110 Rec res
111insertOrSet = R.insert
113----------------------------------------------------------------------------
114-- Generic
115----------------------------------------------------------------------------
117type Sel name value = S1 ('MetaSel ('Just name) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict) (Rec0 value)
119type family Sels fields where
120 Sels '[] = U1
121 Sels '[name R.:= value] = Sel name value
122 Sels ((name R.:= value) ': xs) = Sel name value :*: Sels xs
124type RecordRep fields =
125 D1
126 ('MetaData "Record" "Rec" "" 'False)
127 ( C1
128 ('MetaCons "Record" 'PrefixI 'True)
129 (Sels fields)
130 )
132#ifdef WITH_GENERICS
133instance
134 (R.FromNative (RecordRep fields) fields, R.ToNative (RecordRep fields) fields) =>
135 Generic (Rec fields)
136 where
137 type
138 Rep (Rec fields) =
139 RecordRep fields
140 from r = R.toNative' r
141 to rep = R.fromNative' rep
142#endif
144----------------------------------------------------------------------------
145-- generic-lens
146----------------------------------------------------------------------------
148instance {-# OVERLAPPING #-} (R.Set field fields a' ~ fields', R.Set field fields' a ~ fields, R.Has field fields a, R.Has field fields' a') => GL.HasField field (Rec fields) (Rec fields') a a' where
149 field = R.lens (R.FldProxy @field)
151instance {-# OVERLAPPING #-} (R.Set field fields a ~ fields, R.Has field fields a) => GL.HasField' field (Rec fields) a where
152 field' = R.lens (R.FldProxy @field)
154----------------------------------------------------------------------------
155-- generic-optics
156----------------------------------------------------------------------------
158instance {-# OVERLAPPING #-} (R.Set field fields a' ~ fields', R.Set field fields' a ~ fields, R.Has field fields a, R.Has field fields' a') => GO.HasField field (Rec fields) (Rec fields') a a' where
159 field = R.opticLens (R.FldProxy @field)
161instance {-# OVERLAPPING #-} (R.Set field fields a ~ fields, R.Has field fields a) => GO.HasField' field (Rec fields) a where
162 field' = R.opticLens (R.FldProxy @field)
164pattern Rec ::
165 ( RecTuple tuple fields
166 ) =>
167 tuple ->
168 Rec fields
169pattern Rec a <-
170 (toTuple -> a)
171 where
172 Rec = fromTuple