Skip to content
This repository was archived by the owner on Mar 25, 2021. It is now read-only.

Commit b5f026e

Browse files
paf31paf31
committed
first commit
0 parents  commit b5f026e

4 files changed

Lines changed: 238 additions & 0 deletions

File tree

‎.gitignore‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
/bower_components/
2+
/node_modules/
3+
/.pulp-cache/
4+
/output/
5+
/.psci*
6+
/src/.webpack.js

‎bower.json‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
{
2+
"name": "purescript-generics-rep",
3+
"ignore": [
4+
"**/.*",
5+
"node_modules",
6+
"bower_components",
7+
"output"
8+
],
9+
"dependencies": {
10+
"purescript-prelude": "^1.0.0",
11+
"purescript-monoid": "^1.0.0"
12+
},
13+
"devDependencies": {
14+
"purescript-psci-support": "^1.0.0"
15+
}
16+
}

‎src/Data/Generic/Rep.purs‎

Lines changed: 185 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,185 @@
1+
module Data.Generic.Rep
2+
( class Generic
3+
, to
4+
, from
5+
, NoConstructors
6+
, NoArguments(..)
7+
, Sum(..)
8+
, Product(..)
9+
, Constructor(..)
10+
, Argument(..)
11+
, Rec(..)
12+
, Field(..)
13+
, class GenericEq
14+
, genericEq'
15+
, genericEq
16+
, class GenericOrd
17+
, genericCompare'
18+
, genericCompare
19+
, class GenericSemigroup
20+
, genericAppend'
21+
, genericAppend
22+
, class GenericMonoid
23+
, genericMempty'
24+
, genericMempty
25+
) where
26+
27+
import Prelude
28+
29+
import Data.Monoid (class Monoid, mempty)
30+
31+
-- | A representation for types with no constructors.
32+
data NoConstructors
33+
34+
-- | A representation for constructors with no arguments.
35+
data NoArguments = NoArguments
36+
37+
-- | A representation for types with multiple constructors.
38+
data Sum a b = Inl a | Inr b
39+
40+
-- | A representation for constructors with multiple fields.
41+
data Product a b = Product a b
42+
43+
-- | A representation for constructors which includes the data constructor name
44+
-- | as a type-level string.
45+
newtype Constructor (name :: Symbol) a = Constructor a
46+
47+
-- | A representation for an argument in a data constructor.
48+
newtype Argument a = Argument a
49+
50+
-- | A representation for records.
51+
newtype Rec fields = Rec fields
52+
53+
-- | A representation for a record field which includes the field name
54+
-- | as a type-level string.
55+
newtype Field (field :: Symbol) a = Field a
56+
57+
-- | The `Generic` class asserts the existence of a type function from types
58+
-- | to their representations using the type constructors defined in this module.
59+
class Generic a rep | a -> rep where
60+
to :: rep -> a
61+
from :: a -> rep
62+
63+
class GenericEq a where
64+
genericEq' :: a -> a -> Boolean
65+
66+
instance genericEqNoConstructors :: GenericEq NoConstructors where
67+
genericEq' _ _ = true
68+
69+
instance genericEqNoArguments :: GenericEq NoArguments where
70+
genericEq' _ _ = true
71+
72+
instance genericEqSum :: (GenericEq a, GenericEq b) => GenericEq (Sum a b) where
73+
genericEq' (Inl a1) (Inl a2) = genericEq' a1 a2
74+
genericEq' (Inr b1) (Inr b2) = genericEq' b1 b2
75+
genericEq' _ _ = false
76+
77+
instance genericEqProduct :: (GenericEq a, GenericEq b) => GenericEq (Product a b) where
78+
genericEq' (Product a1 b1) (Product a2 b2) = genericEq' a1 a2 && genericEq' b1 b2
79+
80+
instance genericEqConstructor :: GenericEq a => GenericEq (Constructor name a) where
81+
genericEq' (Constructor a1) (Constructor a2) = genericEq' a1 a2
82+
83+
instance genericEqArgument :: Eq a => GenericEq (Argument a) where
84+
genericEq' (Argument a1) (Argument a2) = a1 == a2
85+
86+
instance genericEqRec :: GenericEq a => GenericEq (Rec a) where
87+
genericEq' (Rec a1) (Rec a2) = genericEq' a1 a2
88+
89+
instance genericEqField :: GenericEq a => GenericEq (Field name a) where
90+
genericEq' (Field a1) (Field a2) = genericEq' a1 a2
91+
92+
-- | A `Generic` implementation of the `eq` member from the `Eq` type class.
93+
genericEq :: forall a rep. (Generic a rep, GenericEq rep) => a -> a -> Boolean
94+
genericEq x y = genericEq' (from x) (from y)
95+
96+
class GenericOrd a where
97+
genericCompare' :: a -> a -> Ordering
98+
99+
instance genericOrdNoConstructors :: GenericOrd NoConstructors where
100+
genericCompare' _ _ = EQ
101+
102+
instance genericOrdNoArguments :: GenericOrd NoArguments where
103+
genericCompare' _ _ = EQ
104+
105+
instance genericOrdSum :: (GenericOrd a, GenericOrd b) => GenericOrd (Sum a b) where
106+
genericCompare' (Inl a1) (Inl a2) = genericCompare' a1 a2
107+
genericCompare' (Inr b1) (Inr b2) = genericCompare' b1 b2
108+
genericCompare' (Inl b1) (Inr b2) = LT
109+
genericCompare' (Inr b1) (Inl b2) = GT
110+
111+
instance genericOrdProduct :: (GenericOrd a, GenericOrd b) => GenericOrd (Product a b) where
112+
genericCompare' (Product a1 b1) (Product a2 b2) =
113+
case genericCompare' a1 a2 of
114+
EQ -> genericCompare' b1 b2
115+
other -> other
116+
117+
instance genericOrdConstructor :: GenericOrd a => GenericOrd (Constructor name a) where
118+
genericCompare' (Constructor a1) (Constructor a2) = genericCompare' a1 a2
119+
120+
instance genericOrdArgument :: Ord a => GenericOrd (Argument a) where
121+
genericCompare' (Argument a1) (Argument a2) = compare a1 a2
122+
123+
instance genericOrdRec :: GenericOrd a => GenericOrd (Rec a) where
124+
genericCompare' (Rec a1) (Rec a2) = genericCompare' a1 a2
125+
126+
instance genericOrdField :: GenericOrd a => GenericOrd (Field name a) where
127+
genericCompare' (Field a1) (Field a2) = genericCompare' a1 a2
128+
129+
-- | A `Generic` implementation of the `compare` member from the `Ord` type class.
130+
genericCompare :: forall a rep. (Generic a rep, GenericOrd rep) => a -> a -> Ordering
131+
genericCompare x y = genericCompare' (from x) (from y)
132+
133+
class GenericSemigroup a where
134+
genericAppend' :: a -> a -> a
135+
136+
instance genericSemigroupNoConstructors :: GenericSemigroup NoConstructors where
137+
genericAppend' a _ = a
138+
139+
instance genericSemigroupNoArguments :: GenericSemigroup NoArguments where
140+
genericAppend' a _ = a
141+
142+
instance genericSemigroupProduct :: (GenericSemigroup a, GenericSemigroup b) => GenericSemigroup (Product a b) where
143+
genericAppend' (Product a1 b1) (Product a2 b2) =
144+
Product (genericAppend' a1 a2) (genericAppend' b1 b2)
145+
146+
instance genericSemigroupConstructor :: GenericSemigroup a => GenericSemigroup (Constructor name a) where
147+
genericAppend' (Constructor a1) (Constructor a2) = Constructor (genericAppend' a1 a2)
148+
149+
instance genericSemigroupArgument :: Semigroup a => GenericSemigroup (Argument a) where
150+
genericAppend' (Argument a1) (Argument a2) = Argument (append a1 a2)
151+
152+
instance genericSemigroupRec :: GenericSemigroup a => GenericSemigroup (Rec a) where
153+
genericAppend' (Rec a1) (Rec a2) = Rec (genericAppend' a1 a2)
154+
155+
instance genericSemigroupField :: GenericSemigroup a => GenericSemigroup (Field name a) where
156+
genericAppend' (Field a1) (Field a2) = Field (genericAppend' a1 a2)
157+
158+
-- | A `Generic` implementation of the `append` member from the `Semigroup` type class.
159+
genericAppend :: forall a rep. (Generic a rep, GenericSemigroup rep) => a -> a -> a
160+
genericAppend x y = to (genericAppend' (from x) (from y))
161+
162+
class GenericMonoid a where
163+
genericMempty' :: a
164+
165+
instance genericMonoidNoArguments :: GenericMonoid NoArguments where
166+
genericMempty' = NoArguments
167+
168+
instance genericMonoidProduct :: (GenericMonoid a, GenericMonoid b) => GenericMonoid (Product a b) where
169+
genericMempty' = Product genericMempty' genericMempty'
170+
171+
instance genericMonoidConstructor :: GenericMonoid a => GenericMonoid (Constructor name a) where
172+
genericMempty' = Constructor genericMempty'
173+
174+
instance genericMonoidArgument :: Monoid a => GenericMonoid (Argument a) where
175+
genericMempty' = Argument mempty
176+
177+
instance genericMonoidRec :: GenericMonoid a => GenericMonoid (Rec a) where
178+
genericMempty' = Rec genericMempty'
179+
180+
instance genericMonoidField :: GenericMonoid a => GenericMonoid (Field name a) where
181+
genericMempty' = Field genericMempty'
182+
183+
-- | A `Generic` implementation of the `mempty` member from the `Monoid` type class.
184+
genericMempty :: forall a rep. (Generic a rep, GenericMonoid rep) => a
185+
genericMempty = to genericMempty'

‎test/Main.purs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
module Test.Main where
2+
3+
import Prelude
4+
import Control.Monad.Eff (Eff)
5+
import Control.Monad.Eff.Console (CONSOLE, logShow)
6+
import Data.Generic.Rep as G
7+
8+
data List a = Nil | Cons a (List a)
9+
10+
instance genericList :: G.Generic (List a)
11+
(G.Sum (G.Constructor "Nil" G.NoArguments)
12+
(G.Constructor "Cons" (G.Product (G.Argument a)
13+
(G.Argument (List a))))) where
14+
to (G.Inl (G.Constructor G.NoArguments)) = Nil
15+
to (G.Inr (G.Constructor (G.Product (G.Argument x) (G.Argument xs)))) = Cons x xs
16+
from Nil = G.Inl (G.Constructor G.NoArguments)
17+
from (Cons x xs) = G.Inr (G.Constructor (G.Product (G.Argument x) (G.Argument xs)))
18+
19+
instance eqList :: Eq a => Eq (List a) where
20+
eq x y = G.genericEq x y
21+
22+
instance ordList :: Ord a => Ord (List a) where
23+
compare x y = G.genericCompare x y
24+
25+
main :: Eff (console :: CONSOLE) Unit
26+
main = do
27+
logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))
28+
logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)
29+
30+
logShow (Cons 1 (Cons 2 Nil) `compare` Cons 1 (Cons 2 Nil))
31+
logShow (Cons 1 (Cons 2 Nil) `compare` Cons 1 Nil)

0 commit comments

Comments
 (0)