git.iko.soy/project-m37
on master help sign in
project-m37/src/JRec.hs
150 lines 3.6 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE PatternSynonyms #-}
4{-# LANGUAGE TypeApplications #-}
6module JRec
7 ( unField,
8 (:=) (..),
9 FldProxy (..),
10 Tup,
11 pattern Tup,
12 append,
13 union,
14 insert,
15 insertOrSet,
16 R.FromNative,
17 R.recCopy,
18 R.get,
19 R.set,
20 R.Has,
21 R.fromNative,
22 R.rnil,
23 R.RemoveAccessTo,
24 R.RecSize,
25 R.RecCopy,
26 )
27where
29import Data.Proxy
30import GHC.Exts (Any)
31import GHC.Generics
32import GHC.OverloadedLabels
33import GHC.Records
34import GHC.TypeLits
35import JRec.Internal (FldProxy (..), Tup, (:=) (..))
36import JRec.Internal qualified as R
37import JRec.Tuple
38import Unsafe.Coerce
40----------------------------------------------------------------------------
41-- unField
42----------------------------------------------------------------------------
44unField :: (field ~ field') => R.FldProxy field -> (field' R.:= value) -> value
45unField _ (_ R.:= value) = value
47----------------------------------------------------------------------------
48-- Other operations
49----------------------------------------------------------------------------
51-- Appends records, without removing duplicates.
52--
53-- O(n + m) type check complexity.
54--
55-- FIXME: See spec for a bug when there are duplicates.
56append ::
57 forall lhs rhs res.
58 (res ~ R.RecAppend lhs rhs) =>
59 Tup lhs ->
60 Tup rhs ->
61 Tup res
62append = R.combine
64-- Merges records, removing duplicates
65--
66-- Left-biased. Does not sort.
67--
68-- O(n * m) type check complexity.
69union ::
70 forall lhs rhs res.
71 ( KnownNat (R.RecSize lhs),
72 KnownNat (R.RecSize rhs),
73 KnownNat (R.RecSize res),
74 res ~ R.Union lhs rhs,
75 R.RecCopy lhs lhs res,
76 R.RecCopy rhs rhs res
77 ) =>
78 Tup lhs ->
79 Tup rhs ->
80 Tup res
81union = R.union
83-- | Insert a field into a record that does not already contain it
84--
85-- O(n) type check complexity.
86insert ::
87 forall label value lts res.
88 ( KnownNat (1 + R.RecSize lts),
89 KnownNat (R.RecSize lts),
90 KnownSymbol label,
91 R.RecCopy lts lts res,
92 res ~ ((label := value) : lts),
93 R.RemoveAccessTo label lts ~ lts
94 ) =>
95 label := value ->
96 Tup lts ->
97 Tup res
98insert = R.combine . Tup
100-- | Insert a field into a record. Set it if it already exists
101--
102-- O(n) type check complexity.
103insertOrSet ::
104 forall label value rhs res.
105 ( KnownNat (R.RecSize rhs),
106 KnownNat (R.RecSize res),
107 KnownNat (R.RecTyIdxH 0 label res),
108 KnownSymbol label,
109 value ~ R.RecTy label res,
110 R.Reverse (R.Insert (label := value) (R.Reverse rhs)) ~ res,
111 R.RecCopy rhs rhs res
112 ) =>
113 label := value ->
114 Tup rhs ->
115 Tup res
116insertOrSet = R.insert
118----------------------------------------------------------------------------
119-- Generic
120----------------------------------------------------------------------------
122type Sel name value = S1 ('MetaSel ('Just name) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict) (Rec0 value)
124type family Sels fields where
125 Sels '[] = U1
126 Sels '[name R.:= value] = Sel name value
127 Sels ((name R.:= value) ': xs) = Sel name value :*: Sels xs
129type RecordRep fields =
130 D1
131 ('MetaData "Record" "Rec" "" 'False)
132 ( C1
133 ('MetaCons "Record" 'PrefixI 'True)
134 (Sels fields)
135 )
137-- instance (R.FromNative (RecordRep fields) fields, R.ToNative (RecordRep fields) fields) => Generic (Tup fields) where
138-- type Rep (Tup fields) = RecordRep fields
139-- from = R.toNative'
140-- to = R.fromNative'
142pattern Tup ::
143 ( RecTuple tuple fields
144 ) =>
145 tuple ->
146 Tup fields
147pattern Tup a <-
148 (toTuple -> a)
149 where
150 Tup = fromTuple