Skip to content

Commit a57a34d

Browse files
garybgaryb
authored
Merge pull request #171 from i-am-tom/compiler/0.12
Instances for Record
2 parents 3c7f84a + 58d513c commit a57a34d

File tree

17 files changed

+506
-10
lines changed

17 files changed

+506
-10
lines changed

‎src/Data/BooleanAlgebra.purs‎

Lines changed: 20 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,14 @@
11
module Data.BooleanAlgebra
22
( class BooleanAlgebra
33
, module Data.HeytingAlgebra
4+
, class BooleanAlgebraRecord
45
) where
56

6-
import Data.HeytingAlgebra (class HeytingAlgebra, ff, tt, implies, conj, disj, not, (&&), (||))
7+
import Data.HeytingAlgebra (class HeytingAlgebra, class HeytingAlgebraRecord, ff, tt, implies, conj, disj, not, (&&), (||))
8+
import Data.Symbol (class IsSymbol)
79
import Data.Unit (Unit)
10+
import Prim.Row as Row
11+
import Prim.RowList as RL
812

913
-- | The `BooleanAlgebra` type class represents types that behave like boolean
1014
-- | values.
@@ -19,3 +23,18 @@ class HeytingAlgebra a <= BooleanAlgebra a
1923
instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
2024
instance booleanAlgebraUnit :: BooleanAlgebra Unit
2125
instance booleanAlgebraFn :: BooleanAlgebra b => BooleanAlgebra (a -> b)
26+
instance booleanAlgebraRecord :: (RL.RowToList row list, BooleanAlgebraRecord list row row) => BooleanAlgebra (Record row)
27+
28+
-- | A class for records where all fields have `BooleanAlgebra` instances, used
29+
-- | to implement the `BooleanAlgebra` instance for records.
30+
class HeytingAlgebraRecord rowlist row subrow <= BooleanAlgebraRecord rowlist row subrow | rowlist -> subrow
31+
32+
instance booleanAlgebraRecordNil :: BooleanAlgebraRecord RL.Nil row ()
33+
34+
instance booleanAlgebraRecordCons
35+
:: ( IsSymbol key
36+
, Row.Cons key focus subrowTail subrow
37+
, BooleanAlgebraRecord rowlistTail row subrowTail
38+
, BooleanAlgebra focus
39+
)
40+
=> BooleanAlgebraRecord (RL.Cons key focus rowlistTail) row subrow

‎src/Data/CommutativeRing.purs‎

Lines changed: 20 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,15 @@ module Data.CommutativeRing
22
( class CommutativeRing
33
, module Data.Ring
44
, module Data.Semiring
5+
, class CommutativeRingRecord
56
) where
67

7-
import Data.Ring (class Ring)
8+
import Data.Ring (class Ring, class RingRecord)
89
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
10+
import Data.Symbol (class IsSymbol)
911
import Data.Unit (Unit)
12+
import Prim.Row as Row
13+
import Prim.RowList as RL
1014

1115
-- | The `CommutativeRing` class is for rings where multiplication is
1216
-- | commutative.
@@ -21,3 +25,18 @@ instance commutativeRingInt :: CommutativeRing Int
2125
instance commutativeRingNumber :: CommutativeRing Number
2226
instance commutativeRingUnit :: CommutativeRing Unit
2327
instance commutativeRingFn :: CommutativeRing b => CommutativeRing (a -> b)
28+
instance commutativeRingRecord :: (RL.RowToList row list, CommutativeRingRecord list row row) => CommutativeRing (Record row)
29+
30+
-- | A class for records where all fields have `CommutativeRing` instances, used
31+
-- | to implement the `CommutativeRing` instance for records.
32+
class RingRecord rowlist row subrow <= CommutativeRingRecord rowlist row subrow | rowlist -> subrow
33+
34+
instance commutativeRingRecordNil :: CommutativeRingRecord RL.Nil row ()
35+
36+
instance commutativeRingRecordCons
37+
:: ( IsSymbol key
38+
, Row.Cons key focus subrowTail subrow
39+
, CommutativeRingRecord rowlistTail row subrowTail
40+
, CommutativeRing focus
41+
)
42+
=> CommutativeRingRecord (RL.Cons key focus rowlistTail) row subrow

‎src/Data/DivisionRing.purs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,9 +7,9 @@ module Data.DivisionRing
77
, module Data.Semiring
88
) where
99

10+
import Data.EuclideanRing ((/))
1011
import Data.Ring (class Ring, negate, sub)
1112
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
12-
import Data.EuclideanRing ((/))
1313

1414
-- | The `DivisionRing` class is for non-zero rings in which every non-zero
1515
-- | element has a multiplicative inverse. Division rings are sometimes also

‎src/Data/Eq.purs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,17 @@
11
module Data.Eq
22
( class Eq, eq, (==), notEq, (/=)
33
, class Eq1, eq1, notEq1
4+
, class EqRecord, eqRecord
45
) where
56

7+
import Data.HeytingAlgebra ((&&))
8+
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
69
import Data.Unit (Unit)
710
import Data.Void (Void)
11+
import Prim.Row as Row
12+
import Prim.RowList as RL
13+
import Record.Unsafe (unsafeGet)
14+
import Type.Data.RowList (RLProxy(..))
815

916
-- | The `Eq` type class represents types which support decidable equality.
1017
-- |
@@ -54,6 +61,9 @@ instance eqVoid :: Eq Void where
5461
instance eqArray :: Eq a => Eq (Array a) where
5562
eq = eqArrayImpl eq
5663

64+
instance eqRec :: (RL.RowToList row list, EqRecord list row) => Eq (Record row) where
65+
eq = eqRecord (RLProxy :: RLProxy list)
66+
5767
foreign import refEq :: forall a. a -> a -> Boolean
5868
foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
5969

@@ -66,3 +76,24 @@ instance eq1Array :: Eq1 Array where
6676

6777
notEq1 :: forall f a. Eq1 f => Eq a => f a -> f a -> Boolean
6878
notEq1 x y = (x `eq1` y) == false
79+
80+
-- | A class for records where all fields have `Eq` instances, used to implement
81+
-- | the `Eq` instance for records.
82+
class EqRecord rowlist row where
83+
eqRecord :: RLProxy rowlist -> Record row -> Record row -> Boolean
84+
85+
instance eqRowNil :: EqRecord RL.Nil row where
86+
eqRecord _ _ _ = true
87+
88+
instance eqRowCons
89+
:: ( EqRecord rowlistTail row
90+
, Row.Cons key focus rowTail row
91+
, IsSymbol key
92+
, Eq focus
93+
)
94+
=> EqRecord (RL.Cons key focus rowlistTail) row where
95+
eqRecord _ ra rb = (get ra == get rb) && tail
96+
where
97+
key = reflectSymbol (SProxy :: SProxy key)
98+
get = unsafeGet key :: Record row -> focus
99+
tail = eqRecord (RLProxy :: RLProxy rowlistTail) ra rb

‎src/Data/HeytingAlgebra.purs‎

Lines changed: 82 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,15 @@
11
module Data.HeytingAlgebra
2-
( class HeytingAlgebra, tt, ff, implies, conj, disj, not
3-
, (&&), (||)
2+
( class HeytingAlgebra, tt, ff, implies, conj, disj, not, (&&), (||)
3+
, class HeytingAlgebraRecord, ffRecord, ttRecord, impliesRecord, conjRecord, disjRecord, notRecord
44
) where
55

6+
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
67
import Data.Unit (Unit, unit)
8+
import Prim.Row as Row
9+
import Prim.RowList as RL
10+
import Record.Unsafe (unsafeGet, unsafeSet)
11+
import Type.Data.Row (RProxy(..))
12+
import Type.Data.RowList (RLProxy(..))
713

814
-- | The `HeytingAlgebra` type class represents types that are bounded lattices with
915
-- | an implication operator such that the following laws hold:
@@ -65,6 +71,80 @@ instance heytingAlgebraFunction :: HeytingAlgebra b => HeytingAlgebra (a -> b) w
6571
disj f g a = f a || g a
6672
not f a = not (f a)
6773

74+
instance heytingAlgebraRecord :: (RL.RowToList row list, HeytingAlgebraRecord list row row) => HeytingAlgebra (Record row) where
75+
ff = ffRecord (RLProxy :: RLProxy list) (RProxy :: RProxy row)
76+
tt = ttRecord (RLProxy :: RLProxy list) (RProxy :: RProxy row)
77+
conj = conjRecord (RLProxy :: RLProxy list)
78+
disj = disjRecord (RLProxy :: RLProxy list)
79+
implies = impliesRecord (RLProxy :: RLProxy list)
80+
not = notRecord (RLProxy :: RLProxy list)
81+
6882
foreign import boolConj :: Boolean -> Boolean -> Boolean
6983
foreign import boolDisj :: Boolean -> Boolean -> Boolean
7084
foreign import boolNot :: Boolean -> Boolean
85+
86+
-- | A class for records where all fields have `HeytingAlgebra` instances, used
87+
-- | to implement the `HeytingAlgebra` instance for records.
88+
class HeytingAlgebraRecord rowlist row subrow | rowlist -> subrow where
89+
ffRecord :: RLProxy rowlist -> RProxy row -> Record subrow
90+
ttRecord :: RLProxy rowlist -> RProxy row -> Record subrow
91+
impliesRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow
92+
disjRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow
93+
conjRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow
94+
notRecord :: RLProxy rowlist -> Record row -> Record subrow
95+
96+
instance heytingAlgebraRecordNil :: HeytingAlgebraRecord RL.Nil row () where
97+
conjRecord _ _ _ = {}
98+
disjRecord _ _ _ = {}
99+
ffRecord _ _ = {}
100+
impliesRecord _ _ _ = {}
101+
notRecord _ _ = {}
102+
ttRecord _ _ = {}
103+
104+
instance heytingAlgebraRecordCons
105+
:: ( IsSymbol key
106+
, Row.Cons key focus subrowTail subrow
107+
, HeytingAlgebraRecord rowlistTail row subrowTail
108+
, HeytingAlgebra focus
109+
)
110+
=> HeytingAlgebraRecord (RL.Cons key focus rowlistTail) row subrow where
111+
conjRecord _ ra rb = insert (conj (get ra) (get rb)) tail
112+
where
113+
key = reflectSymbol (SProxy :: SProxy key)
114+
get = unsafeGet key :: Record row -> focus
115+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
116+
tail = conjRecord (RLProxy :: RLProxy rowlistTail) ra rb
117+
118+
disjRecord _ ra rb = insert (disj (get ra) (get rb)) tail
119+
where
120+
key = reflectSymbol (SProxy :: SProxy key)
121+
get = unsafeGet key :: Record row -> focus
122+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
123+
tail = disjRecord (RLProxy :: RLProxy rowlistTail) ra rb
124+
125+
impliesRecord _ ra rb = insert (implies (get ra) (get rb)) tail
126+
where
127+
key = reflectSymbol (SProxy :: SProxy key)
128+
get = unsafeGet key :: Record row -> focus
129+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
130+
tail = impliesRecord (RLProxy :: RLProxy rowlistTail) ra rb
131+
132+
ffRecord _ row = insert ff tail
133+
where
134+
key = reflectSymbol (SProxy :: SProxy key)
135+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
136+
tail = ffRecord (RLProxy :: RLProxy rowlistTail) row
137+
138+
notRecord _ row
139+
= insert (not (get row)) tail
140+
where
141+
key = reflectSymbol (SProxy :: SProxy key)
142+
get = unsafeGet key :: Record row -> focus
143+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
144+
tail = notRecord (RLProxy :: RLProxy rowlistTail) row
145+
146+
ttRecord _ row = insert tt tail
147+
where
148+
key = reflectSymbol (SProxy :: SProxy key)
149+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
150+
tail = ttRecord (RLProxy :: RLProxy rowlistTail) row

‎src/Data/Monoid.purs‎

Lines changed: 32 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,15 +3,21 @@ module Data.Monoid
33
, power
44
, guard
55
, module Data.Semigroup
6+
, class MonoidRecord, memptyRecord
67
) where
78

89
import Data.Boolean (otherwise)
910
import Data.Eq ((==))
1011
import Data.EuclideanRing (mod, (/))
1112
import Data.Ord ((<=))
1213
import Data.Ordering (Ordering(..))
13-
import Data.Semigroup (class Semigroup, (<>))
14+
import Data.Semigroup (class Semigroup, class SemigroupRecord, (<>))
15+
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
1416
import Data.Unit (Unit, unit)
17+
import Prim.Row as Row
18+
import Prim.RowList as RL
19+
import Record.Unsafe (unsafeSet)
20+
import Type.Data.RowList (RLProxy(..))
1521

1622
-- | A `Monoid` is a `Semigroup` with a value `mempty`, which is both a
1723
-- | left and right unit for the associative operation `<>`:
@@ -41,6 +47,9 @@ instance monoidString :: Monoid String where
4147
instance monoidArray :: Monoid (Array a) where
4248
mempty = []
4349

50+
instance monoidRecord :: (RL.RowToList row list, MonoidRecord list row row) => Monoid (Record row) where
51+
mempty = memptyRecord (RLProxy :: RLProxy list)
52+
4453
-- | Append a value to itself a certain number of times. For the
4554
-- | `Multiplicative` type, and for a non-negative power, this is the same as
4655
-- | normal number exponentiation.
@@ -65,3 +74,25 @@ power x = go
6574
guard :: forall m. Monoid m => Boolean -> m -> m
6675
guard true a = a
6776
guard false _ = mempty
77+
78+
-- | A class for records where all fields have `Monoid` instances, used to
79+
-- | implement the `Monoid` instance for records.
80+
class SemigroupRecord rowlist row subrow <= MonoidRecord rowlist row subrow | rowlist -> row subrow where
81+
memptyRecord :: RLProxy rowlist -> Record subrow
82+
83+
instance monoidRecordNil :: MonoidRecord RL.Nil row () where
84+
memptyRecord _ = {}
85+
86+
instance monoidRecordCons
87+
:: ( IsSymbol key
88+
, Monoid focus
89+
, Row.Cons key focus subrowTail subrow
90+
, MonoidRecord rowlistTail row subrowTail
91+
)
92+
=> MonoidRecord (RL.Cons key focus rowlistTail) row subrow where
93+
memptyRecord _
94+
= insert mempty tail
95+
where
96+
key = reflectSymbol (SProxy :: SProxy key)
97+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
98+
tail = memptyRecord (RLProxy :: RLProxy rowlistTail)

‎src/Data/Ord.purs‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -168,3 +168,37 @@ class Eq1 f <= Ord1 f where
168168

169169
instance ord1Array :: Ord1 Array where
170170
compare1 = compare
171+
172+
-- Ordering for records is currently unimplemented as there are outstanding
173+
-- questions around whether this implementation be useful. This is because it
174+
-- prioritises the keys alphabetically, and this behaviour isn't overridable.
175+
-- For now, we leave this unavailable, but the implementation is as follows:
176+
177+
-- class EqRecord rowlist row focus <= OrdRecord rowlist row focus | rowlist -> focus where
178+
-- compareImpl :: RLProxy rowlist -> Record row -> Record row -> Ordering
179+
--
180+
-- instance ordRecordNil :: OrdRecord RL.Nil row focus where
181+
-- compareImpl _ _ _ = EQ
182+
--
183+
-- instance ordRecordCons
184+
-- :: ( OrdRecord rowlistTail row subfocus
185+
-- , Row.Cons key focus rowTail row
186+
-- , IsSymbol key
187+
-- , Ord focus
188+
-- )
189+
-- => OrdRecord (RL.Cons key focus rowlistTail) row focus where
190+
-- compareImpl _ ra rb
191+
-- = if left /= EQ
192+
-- then left
193+
-- else compareImpl (RLProxy :: RLProxy rowlistTail) ra rb
194+
-- where
195+
-- key = reflectSymbol (SProxy :: SProxy key)
196+
-- unsafeGet' = unsafeGet :: String -> Record row -> focus
197+
-- left = unsafeGet' key ra `compare` unsafeGet' key rb
198+
--
199+
-- instance ordRecord
200+
-- :: ( RL.RowToList row list
201+
-- , OrdRecord list row focus
202+
-- )
203+
-- => Ord (Record row) where
204+
-- compare = compareImpl (RLProxy :: RLProxy list)

‎src/Data/Ring.purs‎

Lines changed: 32 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,16 @@
11
module Data.Ring
22
( class Ring, sub, negate, (-)
33
, module Data.Semiring
4+
, class RingRecord, subRecord
45
) where
56

6-
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
7+
import Data.Semiring (class Semiring, class SemiringRecord, add, mul, one, zero, (*), (+))
8+
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
79
import Data.Unit (Unit, unit)
10+
import Prim.Row as Row
11+
import Prim.RowList as RL
12+
import Record.Unsafe (unsafeGet, unsafeSet)
13+
import Type.Data.RowList (RLProxy(..))
814

915
-- | The `Ring` class is for types that support addition, multiplication,
1016
-- | and subtraction operations.
@@ -30,9 +36,34 @@ instance ringUnit :: Ring Unit where
3036
instance ringFn :: Ring b => Ring (a -> b) where
3137
sub f g x = f x - g x
3238

39+
instance ringRecord :: (RL.RowToList row list, RingRecord list row row) => Ring (Record row) where
40+
sub = subRecord (RLProxy :: RLProxy list)
41+
3342
-- | `negate x` can be used as a shorthand for `zero - x`.
3443
negate :: forall a. Ring a => a -> a
3544
negate a = zero - a
3645

3746
foreign import intSub :: Int -> Int -> Int
3847
foreign import numSub :: Number -> Number -> Number
48+
49+
-- | A class for records where all fields have `Ring` instances, used to
50+
-- | implement the `Ring` instance for records.
51+
class SemiringRecord rowlist row subrow <= RingRecord rowlist row subrow | rowlist -> subrow where
52+
subRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow
53+
54+
instance ringRecordNil :: RingRecord RL.Nil row () where
55+
subRecord _ _ _ = {}
56+
57+
instance ringRecordCons
58+
:: ( IsSymbol key
59+
, Row.Cons key focus subrowTail subrow
60+
, RingRecord rowlistTail row subrowTail
61+
, Ring focus
62+
)
63+
=> RingRecord (RL.Cons key focus rowlistTail) row subrow where
64+
subRecord _ ra rb = insert (get ra - get rb) tail
65+
where
66+
insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
67+
key = reflectSymbol (SProxy :: SProxy key)
68+
get = unsafeGet key :: Record row -> focus
69+
tail = subRecord (RLProxy :: RLProxy rowlistTail) ra rb

0 commit comments

Comments
 (0)