git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #872 from purescript/num

Revise Num class hierarchy

commit8f3e5e42252b54d00773cb72cb97fd5987e34027 authorGary Burgess <gary.burgess@gmail.com> dateMon 16 Feb 2015, 00:14 (12 years ago) parent9aa8b9209bd21d
8 files changed+170−67
compare with golang
unifiedsplit
examples/passing/OneConstructor.purs+1−1 examples/passing/Rank2Data.purs+6−6 examples/passing/ShadowedTCO.purs+5−5 prelude/README.md+61−12 prelude/prelude.purs+53−25 src/Language/PureScript/CodeGen/JS/Optimizer.hs+1 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+28−18 src/Language/PureScript/Constants.hs+15
examples/passing/OneConstructor.purs+1−1
@@ -2,6 +2,6 @@ module Main where
22
33data One a = One a
44
5−one (One a) = a
5+one' (One a) = a
66
77main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.purs+6−6
@@ -12,18 +12,18 @@ module Main where
1212 runNat = \nat -> case nat of
1313 Nat f -> f 0 (\n -> n + 1)
1414
15− zero = Nat (\zero _ -> zero)
15+ zero' = Nat (\zero' _ -> zero')
1616
1717 succ = \n -> case n of
18− Nat f -> Nat (\zero succ -> succ (f zero succ))
18+ Nat f -> Nat (\zero' succ -> succ (f zero' succ))
1919
2020 add = \n m -> case n of
2121 Nat f -> case m of
22− Nat g -> Nat (\zero succ -> g (f zero succ) succ)
22+ Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)
2323
24− one = succ zero
25− two = succ zero
24+ one' = succ zero'
25+ two = succ zero'
2626 four = add two two
2727 fourNumber = runNat four
2828
29− main = Debug.Trace.trace "Done"
29+ main = Debug.Trace.trace "Done'"
examples/passing/ShadowedTCO.purs+5−5
@@ -2,14 +2,14 @@ module Main where
22
33runNat f = f 0 (\n -> n + 1)
44
5−zero z _ = z
5+zero' z _ = z
66
7−succ f zero succ = succ (f zero succ)
7+succ f zero' succ = succ (f zero' succ)
88
9−add f g zero succ = g (f zero succ) succ
9+add f g zero' succ = g (f zero' succ) succ
1010
11−one = succ zero
12−two = succ one
11+one' = succ zero'
12+two = succ one'
1313four = add two two
1414fourNumber = runNat four
1515
prelude/README.md+61−12
@@ -59,6 +59,13 @@
5959 class (Semigroupoid a) <= Category a where
6060 id :: forall t. a t t
6161
62+#### `DivisionRing`
63+
64+Ring where every nonzero element has a multiplicative inverse (possibly
65+a non-commutative field) so that ```a `mod` b = zero```
66+
67+ class (ModuloRing a) <= DivisionRing a where
68+
6269#### `Eq`
6370
6471 class Eq a where
@@ -70,25 +77,37 @@
7077 class Functor f where
7178 (<$>) :: forall a b. (a -> b) -> f a -> f b
7279
80+#### `ModuloRing`
81+
82+Ring with modulo operation and division where
83+```a / b * b + (a `mod` b) = a```
84+
85+ class (Ring a) <= ModuloRing a where
86+ (/) :: a -> a -> a
87+ mod :: a -> a -> a
88+
7389#### `Monad`
7490
7591 class (Applicative m, Bind m) <= Monad m where
7692
7793#### `Num`
7894
79− class Num a where
80− (+) :: a -> a -> a
81− (-) :: a -> a -> a
82− (*) :: a -> a -> a
83− (/) :: a -> a -> a
84− (%) :: a -> a -> a
85− negate :: a -> a
95+A commutative field
96+
97+ class (DivisionRing a) <= Num a where
8698
8799#### `Ord`
88100
89101 class (Eq a) <= Ord a where
90102 compare :: a -> a -> Ordering
91103
104+#### `Ring`
105+
106+Addition, multiplication, and subtraction
107+
108+ class (Semiring a) <= Ring a where
109+ (-) :: a -> a -> a
110+
92111#### `Semigroup`
93112
94113 class Semigroup a where
@@ -99,6 +118,16 @@
99118 class Semigroupoid a where
100119 (<<<) :: forall b c d. a c d -> a b c -> a b d
101120
121+#### `Semiring`
122+
123+Addition and multiplication
124+
125+ class Semiring a where
126+ (+) :: a -> a -> a
127+ zero :: a
128+ (*) :: a -> a -> a
129+ one :: a
130+
102131#### `Show`
103132
104133 class Show a where
@@ -131,6 +160,10 @@
131160
132161 instance categoryArr :: Category Prim.Function
133162
163+#### `divisionRingNumber`
164+
165+ instance divisionRingNumber :: DivisionRing Number
166+
134167#### `eqArray`
135168
136169 instance eqArray :: (Eq a) => Eq [a]
@@ -159,6 +192,10 @@
159192
160193 instance functorArr :: Functor (Prim.Function r)
161194
195+#### `moduloRingNumber`
196+
197+ instance moduloRingNumber :: ModuloRing Number
198+
162199#### `monadArr`
163200
164201 instance monadArr :: Monad (Prim.Function r)
@@ -187,6 +224,10 @@
187224
188225 instance ordUnit :: Ord Unit
189226
227+#### `ringNumber`
228+
229+ instance ringNumber :: Ring Number
230+
190231#### `semigroupArr`
191232
192233 instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')
@@ -203,6 +244,10 @@
203244
204245 instance semigroupoidArr :: Semigroupoid Prim.Function
205246
247+#### `semiringNumber`
248+
249+ instance semiringNumber :: Semiring Number
250+
206251#### `showArray`
207252
208253 instance showArray :: (Show a) => Show [a]
@@ -277,7 +322,7 @@
277322#### `asTypeOf`
278323
279324This function returns its first argument, and can be used to assert type equalities.
280−This can be useful when types are otherwise ambiguous.
325+This can be useful when types are otherwise ambiguous.
281326
282327E.g.
283328
@@ -294,13 +339,13 @@ been ambiguous, resulting in a compile-time error.
294339
295340#### `const`
296341
297−Returns its first argument and ignores its second.
342+Returns its first argument and ignores its second.
298343
299344 const :: forall a b. a -> b -> a
300345
301346#### `flip`
302347
303−Flips the order of the arguments to a function of two arguments.
348+Flips the order of the arguments to a function of two arguments.
304349
305350 flip :: forall a b c. (a -> b -> c) -> b -> a -> c
306351
@@ -312,13 +357,17 @@ Flips the order of the arguments to a function of two arguments.
312357
313358 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
314359
360+#### `negate`
361+
362+ negate :: forall a. (Ring a) => a -> a
363+
315364#### `otherwise`
316365
317−An alias for `true`, which can be useful in guard clauses:
366+An alias for `true`, which can be useful in guard clauses:
318367
319368E.g.
320369
321− max x y | x >= y = x
370+ max x y | x >= y = x
322371 | otherwise = y
323372
324373 otherwise :: Boolean
prelude/prelude.purs+53−25
@@ -13,8 +13,13 @@ module Prelude
1313 , Applicative, pure, liftA1
1414 , Bind, (>>=)
1515 , Monad, return, liftM1, ap
16− , Num, (+), (-), (*), (/), (%)
16+ , Semiring, (+), zero, (*), one
17+ , Ring, (-)
18+ , (%)
1719 , negate
20+ , ModuloRing, (/), mod
21+ , DivisionRing
22+ , Num
1823 , Eq, (==), (/=), refEq, refIneq
1924 , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
2025 , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
@@ -24,28 +29,28 @@ module Prelude
2429 , Unit(..), unit
2530 ) where
2631
27− -- | An alias for `true`, which can be useful in guard clauses:
28− -- |
32+ -- | An alias for `true`, which can be useful in guard clauses:
33+ -- |
2934 -- | E.g.
30− -- |
31− -- | max x y | x >= y = x
35+ -- |
36+ -- | max x y | x >= y = x
3237 -- | | otherwise = y
3338 otherwise :: Boolean
3439 otherwise = true
3540
36− -- | Flips the order of the arguments to a function of two arguments.
41+ -- | Flips the order of the arguments to a function of two arguments.
3742 flip :: forall a b c. (a -> b -> c) -> b -> a -> c
3843 flip f b a = f a b
3944
40− -- | Returns its first argument and ignores its second.
45+ -- | Returns its first argument and ignores its second.
4146 const :: forall a b. a -> b -> a
4247 const a _ = a
4348
4449 -- | This function returns its first argument, and can be used to assert type equalities.
45− -- | This can be useful when types are otherwise ambiguous.
46− -- |
50+ -- | This can be useful when types are otherwise ambiguous.
51+ -- |
4752 -- | E.g.
48− -- |
53+ -- |
4954 -- | main = print $ [] `asTypeOf` [0]
5055 -- |
5156 -- | If instead, we had written `main = print []`, the type of the argument `[]` would have
@@ -205,13 +210,32 @@ module Prelude
205210 infixl 6 -
206211 infixl 6 +
207212
208− class Num a where
209− (+) :: a -> a -> a
213+ -- | Addition and multiplication
214+ class Semiring a where
215+ (+) :: a -> a -> a
216+ zero :: a
217+ (*) :: a -> a -> a
218+ one :: a
219+
220+ -- | Addition, multiplication, and subtraction
221+ class (Semiring a) <= Ring a where
210222 (-) :: a -> a -> a
211− (*) :: a -> a -> a
223+
224+ negate :: forall a. (Ring a) => a -> a
225+ negate a = zero - a
226+
227+ -- | Ring with modulo operation and division where
228+ -- | ```a / b * b + (a `mod` b) = a```
229+ class (Ring a) <= ModuloRing a where
212230 (/) :: a -> a -> a
213− (%) :: a -> a -> a
214− negate :: a -> a
231+ mod :: a -> a -> a
232+
233+ -- | Ring where every nonzero element has a multiplicative inverse (possibly
234+ -- | a non-commutative field) so that ```a `mod` b = zero```
235+ class (ModuloRing a) <= DivisionRing a
236+
237+ -- | A commutative field
238+ class (DivisionRing a) <= Num a
215239
216240 foreign import numAdd
217241 """
@@ -258,20 +282,24 @@ module Prelude
258282 }
259283 """ :: Number -> Number -> Number
260284
261− foreign import numNegate
262− """
263− function numNegate(n) {
264− return -n;
265− }
266− """ :: Number -> Number
285+ (%) = numMod
267286
268− instance numNumber :: Num Number where
287+ instance semiringNumber :: Semiring Number where
269288 (+) = numAdd
270− (-) = numSub
289+ zero = 0
271290 (*) = numMul
291+ one = 1
292+
293+ instance ringNumber :: Ring Number where
294+ (-) = numSub
295+
296+ instance moduloRingNumber :: ModuloRing Number where
272297 (/) = numDiv
273− (%) = numMod
274− negate = numNegate
298+ mod _ _ = 0
299+
300+ instance divisionRingNumber :: DivisionRing Number
301+
302+ instance numNumber :: Num Number
275303
276304 newtype Unit = Unit {}
277305
src/Language/PureScript/CodeGen/JS/Optimizer.hs+1
@@ -63,6 +63,7 @@ optimize opts | optionsNoOptimizations opts = id
6363 , etaConvert
6464 , evaluateIifes
6565 , inlineVariables
66+ , inlineValues
6667 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
6768 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
6869 , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+28−18
@@ -15,6 +15,7 @@
1515
1616module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
1717 inlineVariables,
18+ inlineValues,
1819 inlineOperator,
1920 inlineCommonOperators,
2021 etaConvert,
@@ -79,6 +80,15 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
7980 go (map (replaceIdent var js) sts)
8081 go (s:sts) = s : go sts
8182
83+inlineValues :: JS -> JS
84+inlineValues = everywhereOnJS convert
85+ where
86+ convert :: JS -> JS
87+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)
88+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)
89+ convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y
90+ convert other = other
91+
8292inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
8393inlineOperator (m, op) f = everywhereOnJS convert
8494 where
@@ -91,12 +101,11 @@ inlineOperator (m, op) f = everywhereOnJS convert
91101
92102inlineCommonOperators :: JS -> JS
93103inlineCommonOperators = applyAll $
94− [ binary C.numNumber (C.+) Add
95− , binary C.numNumber (C.-) Subtract
96− , binary C.numNumber (C.*) Multiply
97− , binary C.numNumber (C./) Divide
98− , binary C.numNumber (C.%) Modulus
99− , unary C.numNumber C.negate Negate
104+ [ binary C.semiringNumber (C.+) Add
105+ , binary C.semiringNumber (C.*) Multiply
106+ , binary C.ringNumber (C.-) Subtract
107+ , unary C.ringNumber C.negate Negate
108+ , binary C.moduloRingNumber (C./) Divide
100109
101110 , binary C.ordNumber (C.<) LessThan
102111 , binary C.ordNumber (C.>) GreaterThan
@@ -131,29 +140,20 @@ inlineCommonOperators = applyAll $
131140 binary dictName opString op = everywhereOnJS convert
132141 where
133142 convert :: JS -> JS
134− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
143+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y
135144 convert other = other
136− isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
137− isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
138− isOp _ = False
139145 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
140146 binaryFunction dictName fnName op = everywhereOnJS convert
141147 where
142148 convert :: JS -> JS
143− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
149+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y
144150 convert other = other
145− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
146− isOp _ = False
147151 unary :: String -> String -> UnaryOperator -> JS -> JS
148152 unary dictName fnName op = everywhereOnJS convert
149153 where
150154 convert :: JS -> JS
151− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
155+ convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x
152156 convert other = other
153− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
154− isOp _ = False
155− isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
156− isOpDict _ _ = False
157157 mkFn :: Int -> JS -> JS
158158 mkFn 0 = everywhereOnJS convert
159159 where
@@ -189,3 +189,13 @@ inlineCommonOperators = applyAll $
189189 go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
190190 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
191191 go _ _ _ = Nothing
192+
193+isPreludeDict :: String -> JS -> Bool
194+isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
195+isPreludeDict _ _ = False
196+
197+isPreludeFn :: String -> JS -> Bool
198+isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
199+isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
200+isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)
201+isPreludeFn _ _ = False
src/Language/PureScript/Constants.hs+15
@@ -105,6 +105,12 @@ not = "not"
105105
106106-- Prelude Values
107107
108+zero :: String
109+zero = "zero"
110+
111+one :: String
112+one = "one"
113+
108114return :: String
109115return = "return"
110116
@@ -163,6 +169,15 @@ applicativeEffDictionary = "applicativeEff"
163169bindEffDictionary :: String
164170bindEffDictionary = "bindEff"
165171
172+semiringNumber :: String
173+semiringNumber = "semiringNumber"
174+
175+ringNumber :: String
176+ringNumber = "ringNumber"
177+
178+moduloRingNumber :: String
179+moduloRingNumber = "moduloRingNumber"
180+
166181numNumber :: String
167182numNumber = "numNumber"
168183