git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Named type class instances
8b6c26ePhil Freeman
RELEASE-0.5.md+5
compare with golang
unifiedsplit
@@ -3,6 +3,10 @@
3## Breaking Changes
3## Breaking Changes
4
4
5- Support for blocks has been removed. (paf31)
5- Support for blocks has been removed. (paf31)
6+- Type class instances must now be named (paf31)
7+
8+ instance showNumber :: Show Number where
9+ ...
6
10
7### New Features
11### New Features
8
12
@@ -24,6 +28,7 @@
24- PSCI history is in XDG config (joneshf)
28- PSCI history is in XDG config (joneshf)
25- PSCI allows loading of modules from ~ paths (joneshf)
29- PSCI allows loading of modules from ~ paths (joneshf)
26- PSCI can accept a list of modules to load on start from the command line (paf31)
30- PSCI can accept a list of modules to load on start from the command line (paf31)
31+- Type class instances are now named, to enable easier interop with Javascript (paf31)
27
32
28### Bug Fixes
33### Bug Fixes
29
34
docgen/Main.hs+3−3
@@ -102,11 +102,11 @@ renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
102renderDeclaration n (P.TypeClassDeclaration name args ds) = do
102renderDeclaration n (P.TypeClassDeclaration name args ds) = do
103 atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
103 atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
104 mapM_ (renderDeclaration (n + 2)) ds
104 mapM_ (renderDeclaration (n + 2)) ds
105−renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do
105+renderDeclaration n (P.TypeInstanceDeclaration name constraints className tys _) = do
106 let constraintsText = case constraints of
106 let constraintsText = case constraints of
107 [] -> ""
107 [] -> ""
108 cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "
108 cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "
109− atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
109+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " :: " ++ show className ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
110renderDeclaration _ _ = return ()
110renderDeclaration _ _ = return ()
111
111
112getName :: P.Declaration -> String
112getName :: P.Declaration -> String
@@ -116,7 +116,7 @@ getName (P.DataDeclaration name _ _) = P.runProperName name
116getName (P.ExternDataDeclaration name _) = P.runProperName name
116getName (P.ExternDataDeclaration name _) = P.runProperName name
117getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
117getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
118getName (P.TypeClassDeclaration name _ _) = P.runProperName name
118getName (P.TypeClassDeclaration name _ _) = P.runProperName name
119−getName (P.TypeInstanceDeclaration _ name _ _) = show name
119+getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
120getName _ = error "Invalid argument to getName"
120getName _ = error "Invalid argument to getName"
121
121
122isValueDeclaration :: P.Declaration -> Bool
122isValueDeclaration :: P.Declaration -> Bool
examples/passing/Applicative.purs+1−1
@@ -6,7 +6,7 @@ class Applicative f where
6
6
7data Maybe a = Nothing | Just a
7data Maybe a = Nothing | Just a
8
8
9−instance Applicative Maybe where
9+instance applicativeMaybe :: Applicative Maybe where
10 pure = Just
10 pure = Just
11 (<*>) (Just f) (Just a) = Just (f a)
11 (<*>) (Just f) (Just a) = Just (f a)
12 (<*>) _ _ = Nothing
12 (<*>) _ _ = Nothing
examples/passing/ArrayType.purs+1−1
@@ -8,7 +8,7 @@ class Functor f where
8
8
9foreign import (:) :: forall a. a -> [a] -> [a]
9foreign import (:) :: forall a. a -> [a] -> [a]
10
10
11−instance Functor [] where
11+instance functorArray :: Functor [] where
12 fmap _ [] = []
12 fmap _ [] = []
13 fmap f (x:xs) = f x : fmap f xs
13 fmap f (x:xs) = f x : fmap f xs
14
14
examples/passing/Do.purs+1−1
@@ -4,7 +4,7 @@ import Prelude
4
4
5data Maybe a = Nothing | Just a
5data Maybe a = Nothing | Just a
6
6
7−instance Prelude.Monad Maybe where
7+instance monadMaybe :: Prelude.Monad Maybe where
8 return = Just
8 return = Just
9 (>>=) Nothing _ = Nothing
9 (>>=) Nothing _ = Nothing
10 (>>=) (Just a) f = f a
10 (>>=) (Just a) f = f a
examples/passing/DottedModules.purs+1−1
@@ -12,7 +12,7 @@ module Main where
12 import Prelude
12 import Prelude
13 import Some.Module.Name
13 import Some.Module.Name
14
14
15− instance Some.Module.Name.Foo String where
15+ instance fooString :: Some.Module.Name.Foo String where
16 foo s = s
16 foo s = s
17
17
18 unwrap (Text x) = x
18 unwrap (Text x) = x
examples/passing/EmptyTypeClass.purs+1−1
@@ -7,7 +7,7 @@ head (x:xs) = x
7
7
8module AllowPartialFns where
8module AllowPartialFns where
9
9
10−instance EmptyTypeClass.Partial
10+instance allowPartials :: EmptyTypeClass.Partial
11
11
12module Main where
12module Main where
13
13
examples/passing/MPTCs.purs+4−4
@@ -6,19 +6,19 @@ import Data.Array
6class NullaryTypeClass where
6class NullaryTypeClass where
7 greeting :: String
7 greeting :: String
8
8
9−instance NullaryTypeClass where
9+instance nullaryTypeClass :: NullaryTypeClass where
10 greeting = "Hello, World!"
10 greeting = "Hello, World!"
11
11
12class Coerce a b where
12class Coerce a b where
13 coerce :: a -> b
13 coerce :: a -> b
14
14
15−instance Coerce a a where
15+instance coerceRefl :: Coerce a a where
16 coerce a = a
16 coerce a = a
17
17
18−instance (Prelude.Show a) => Coerce a String where
18+instance coerceShow :: (Prelude.Show a) => Coerce a String where
19 coerce = show
19 coerce = show
20
20
21−instance (Coerce a b) => Coerce [a] [b] where
21+instance coerceArray :: (Coerce a b) => Coerce [a] [b] where
22 coerce = map coerce
22 coerce = map coerce
23
23
24main = Debug.Trace.print $ coerce [greeting] :: [String]
24main = Debug.Trace.print $ coerce [greeting] :: [String]
examples/passing/MonadState.purs+2−2
@@ -11,12 +11,12 @@ data State s a = State (s -> Tuple s a)
11
11
12runState s (State f) = f s
12runState s (State f) = f s
13
13
14−instance Prelude.Monad (State s) where
14+instance monadState :: Prelude.Monad (State s) where
15 return a = State $ \s -> Tuple s a
15 return a = State $ \s -> Tuple s a
16 (>>=) f g = State $ \s -> let (Tuple s1 a) = runState s f in
16 (>>=) f g = State $ \s -> let (Tuple s1 a) = runState s f in
17 runState s1 (g a)
17 runState s1 (g a)
18
18
19−instance MonadState s (State s) where
19+instance monadStateState :: MonadState s (State s) where
20 get = State (\s -> Tuple s s)
20 get = State (\s -> Tuple s s)
21 put s = State (\_ -> Tuple s {})
21 put s = State (\_ -> Tuple s {})
22
22
examples/passing/RuntimeScopeIssue.purs+2−2
@@ -8,11 +8,11 @@ class A a where
8class B a where
8class B a where
9 b :: a -> Boolean
9 b :: a -> Boolean
10
10
11−instance A Number where
11+instance aNumber :: A Number where
12 a 0 = true
12 a 0 = true
13 a n = b (n - 1)
13 a n = b (n - 1)
14
14
15−instance B Number where
15+instance bNumber :: B Number where
16 b 0 = false
16 b 0 = false
17 b n = a (n - 1)
17 b n = a (n - 1)
18
18
examples/passing/TypeClasses.purs+5−5
@@ -16,18 +16,18 @@ test8 = \_ -> show $ "testing"
16
16
17data Data a = Data a
17data Data a = Data a
18
18
19−instance (Prelude.Show a) => Prelude.Show (Data a) where
19+instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
20 show (Data a) = "Data (" ++ show a ++ ")"
20 show (Data a) = "Data (" ++ show a ++ ")"
21
21
22test3 = \_ -> show (Data "testing")
22test3 = \_ -> show (Data "testing")
23
23
24−instance Prelude.Monad Data where
24+instance monadData :: Prelude.Monad Data where
25 return = Data
25 return = Data
26 (>>=) (Data a) f = f a
26 (>>=) (Data a) f = f a
27
27
28data Maybe a = Nothing | Just a
28data Maybe a = Nothing | Just a
29
29
30−instance Prelude.Monad Maybe where
30+instance monadMaybe :: Prelude.Monad Maybe where
31 return = Just
31 return = Just
32 (>>=) Nothing _ = Nothing
32 (>>=) Nothing _ = Nothing
33 (>>=) (Just a) f = f a
33 (>>=) (Just a) f = f a
@@ -42,13 +42,13 @@ module TypeClasses2 where
42import Prelude
42import Prelude
43import TypeClasses
43import TypeClasses
44
44
45−instance (Prelude.Show a) => Prelude.Show [a] where
45+instance showArray :: (Prelude.Show a) => Prelude.Show [a] where
46 show [] = "[]"
46 show [] = "[]"
47 show (x:xs) = show x ++ ", " ++ show xs
47 show (x:xs) = show x ++ ", " ++ show xs
48
48
49test6 = \_ -> show ["testing"]
49test6 = \_ -> show ["testing"]
50
50
51−instance Prelude.Monad ((->) r) where
51+instance monadFunction :: Prelude.Monad ((->) r) where
52 return a r = a
52 return a r = a
53 (>>=) f g r = g (f r) r
53 (>>=) f g r = g (f r) r
54
54
examples/passing/TypeClassesInOrder.purs+1−1
@@ -5,7 +5,7 @@ import Prelude
5class Foo a where
5class Foo a where
6 foo :: a -> String
6 foo :: a -> String
7
7
8−instance Foo String where
8+instance fooString :: Foo String where
9 foo s = s
9 foo s = s
10
10
11main = Debug.Trace.trace $ foo "Done"
11main = Debug.Trace.trace $ foo "Done"
examples/passing/TypeClassesWithOverlappingTypeVariables.purs+1−1
@@ -3,7 +3,7 @@ module Main where
3 import Prelude
3 import Prelude
4 import Data.Either
4 import Data.Either
5
5
6− instance Prelude.Functor (Either a) where
6+ instance functorEither :: Prelude.Functor (Either a) where
7 (<$>) _ (Left x) = Left x
7 (<$>) _ (Left x) = Left x
8 (<$>) f (Right y) = Right (f y)
8 (<$>) f (Right y) = Right (f y)
9
9
prelude/prelude.purs+68−64
@@ -14,7 +14,7 @@ module Prelude where
14 (<<<) :: forall b c d. a c d -> a b c -> a b d
14 (<<<) :: forall b c d. a c d -> a b c -> a b d
15 (>>>) :: forall b c d. a b c -> a c d -> a b d
15 (>>>) :: forall b c d. a b c -> a c d -> a b d
16
16
17− instance Category (->) where
17+ instance categoryArr :: Category (->) where
18 id x = x
18 id x = x
19 (<<<) f g x = f (g x)
19 (<<<) f g x = f (g x)
20 (>>>) f g x = g (f x)
20 (>>>) f g x = g (f x)
@@ -31,36 +31,36 @@ module Prelude where
31 class Show a where
31 class Show a where
32 show :: a -> String
32 show :: a -> String
33
33
34− instance Show String where
34+ instance showString :: Show String where
35 show s = s
35 show s = s
36
36
37− instance Show Boolean where
37+ instance showBoolean :: Show Boolean where
38 show true = "true"
38 show true = "true"
39 show false = "false"
39 show false = "false"
40
40
41− foreign import showNumber "function showNumber(n) {\
41+ foreign import showNumberImpl "function showNumberImpl(n) {\
42− \ return n.toString();\
42+ \ return n.toString();\
43− \}" :: Number -> String
43+ \}" :: Number -> String
44
44
45− instance Show Number where
45+ instance showNumber :: Show Number where
46− show = showNumber
46+ show = showNumberImpl
47
47
48 class Read a where
48 class Read a where
49 read :: String -> a
49 read :: String -> a
50
50
51− instance Read String where
51+ instance readString :: Read String where
52 read s = s
52 read s = s
53
53
54− instance Read Boolean where
54+ instance readBoolean :: Read Boolean where
55 read "true" = true
55 read "true" = true
56 read _ = false
56 read _ = false
57
57
58− foreign import readNumber "function readNumber(n) {\
58+ foreign import readNumberImpl "function readNumber(n) {\
59− \ return parseFloat(n);\
59+ \ return parseFloat(n);\
60− \}" :: String -> Number
60+ \}" :: String -> Number
61
61
62− instance Read Number where
62+ instance readNumber :: Read Number where
63− read = readNumber
63+ read = readNumberImpl
64
64
65 infixl 4 <$>
65 infixl 4 <$>
66
66
@@ -73,7 +73,7 @@ module Prelude where
73 pure :: forall a. a -> f a
73 pure :: forall a. a -> f a
74 (<*>) :: forall a b. f (a -> b) -> f a -> f b
74 (<*>) :: forall a b. f (a -> b) -> f a -> f b
75
75
76− instance (Applicative f) => Functor f where
76+ instance functorFromApplicative :: (Applicative f) => Functor f where
77 (<$>) f a = pure f <*> a
77 (<$>) f a = pure f <*> a
78
78
79 infixl 3 <|>
79 infixl 3 <|>
@@ -88,7 +88,7 @@ module Prelude where
88 return :: forall a. a -> m a
88 return :: forall a. a -> m a
89 (>>=) :: forall a b. m a -> (a -> m b) -> m b
89 (>>=) :: forall a b. m a -> (a -> m b) -> m b
90
90
91− instance (Monad m) => Applicative m where
91+ instance applicativeFromMonad :: (Monad m) => Applicative m where
92 pure = return
92 pure = return
93 (<*>) f a = do
93 (<*>) f a = do
94 f' <- f
94 f' <- f
@@ -144,7 +144,7 @@ module Prelude where
144 \ return -n;\
144 \ return -n;\
145 \}" :: Number -> Number
145 \}" :: Number -> Number
146
146
147− instance Num Number where
147+ instance numNumber :: Num Number where
148 (+) = numAdd
148 (+) = numAdd
149 (-) = numSub
149 (-) = numSub
150 (*) = numMul
150 (*) = numMul
@@ -159,18 +159,6 @@ module Prelude where
159 (==) :: a -> a -> Boolean
159 (==) :: a -> a -> Boolean
160 (/=) :: a -> a -> Boolean
160 (/=) :: a -> a -> Boolean
161
161
162− -- Referential equality
163− data Ref a = Ref a
164−
165− liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
166− liftRef f (Ref x) (Ref y) = f x y
167−
168− refEq :: forall a. Ref a -> Ref a -> Boolean
169− refEq = liftRef unsafeRefEq
170−
171− refIneq :: forall a. Ref a -> Ref a -> Boolean
172− refIneq = liftRef unsafeRefIneq
173−
174 foreign import unsafeRefEq "function unsafeRefEq(r1) {\
162 foreign import unsafeRefEq "function unsafeRefEq(r1) {\
175 \ return function(r2) {\
163 \ return function(r2) {\
176 \ return r1 === r2;\
164 \ return r1 === r2;\
@@ -183,23 +171,19 @@ module Prelude where
183 \ };\
171 \ };\
184 \}" :: forall a. a -> a -> Boolean
172 \}" :: forall a. a -> a -> Boolean
185
173
186− instance Eq (Ref a) where
187− (==) = refEq
188− (/=) = refIneq
189−
190− instance Eq String where
174+ instance eqString :: Eq String where
191 (==) = unsafeRefEq
175 (==) = unsafeRefEq
192 (/=) = unsafeRefIneq
176 (/=) = unsafeRefIneq
193
177
194− instance Eq Number where
178+ instance eqNumber :: Eq Number where
195 (==) = unsafeRefEq
179 (==) = unsafeRefEq
196 (/=) = unsafeRefIneq
180 (/=) = unsafeRefIneq
197
181
198− instance Eq Boolean where
182+ instance eqBoolean :: Eq Boolean where
199 (==) = unsafeRefEq
183 (==) = unsafeRefEq
200 (/=) = unsafeRefIneq
184 (/=) = unsafeRefIneq
201
185
202− instance (Eq a) => Eq [a] where
186+ instance eqArray :: (Eq a) => Eq [a] where
203 (==) [] [] = true
187 (==) [] [] = true
204 (==) (x:xs) (y:ys) = x == y && xs == ys
188 (==) (x:xs) (y:ys) = x == y && xs == ys
205 (==) _ _ = false
189 (==) _ _ = false
@@ -240,7 +224,7 @@ module Prelude where
240 \ };\
224 \ };\
241 \}" :: Number -> Number -> Boolean
225 \}" :: Number -> Number -> Boolean
242
226
243− instance Ord Number where
227+ instance ordNumber :: Ord Number where
244 (<) = numLess
228 (<) = numLess
245 (>) = numGreater
229 (>) = numGreater
246 (<=) = numLessEq
230 (<=) = numLessEq
@@ -299,7 +283,7 @@ module Prelude where
299 \ return ~n;\
283 \ return ~n;\
300 \}" :: Number -> Number
284 \}" :: Number -> Number
301
285
302− instance Bits Number where
286+ instance bitsNumber :: Bits Number where
303 (&) = numAnd
287 (&) = numAnd
304 (|) = numOr
288 (|) = numOr
305 (^) = numXor
289 (^) = numXor
@@ -340,7 +324,7 @@ module Prelude where
340 \ return !b;\
324 \ return !b;\
341 \}" :: Boolean -> Boolean
325 \}" :: Boolean -> Boolean
342
326
343− instance BoolLike Boolean where
327+ instance boolLikeBoolean :: BoolLike Boolean where
344 (&&) = boolAnd
328 (&&) = boolAnd
345 (||) = boolOr
329 (||) = boolOr
346 not = boolNot
330 not = boolNot
@@ -364,11 +348,11 @@ module Data.Monoid where
364 mempty :: m
348 mempty :: m
365 (<>) :: m -> m -> m
349 (<>) :: m -> m -> m
366
350
367− instance Monoid String where
351+ instance monoidString :: Monoid String where
368 mempty = ""
352 mempty = ""
369 (<>) = (++)
353 (<>) = (++)
370
354
371− instance Monoid [a] where
355+ instance monoidArray :: Monoid [a] where
372 mempty = []
356 mempty = []
373 (<>) = Data.Array.concat
357 (<>) = Data.Array.concat
374
358
@@ -441,20 +425,20 @@ module Data.Maybe where
441 fromMaybe :: forall a. a -> Maybe a -> a
425 fromMaybe :: forall a. a -> Maybe a -> a
442 fromMaybe a = maybe a (id :: forall a. a -> a)
426 fromMaybe a = maybe a (id :: forall a. a -> a)
443
427
444− instance Monad Maybe where
428+ instance monadMaybe :: Monad Maybe where
445 return = Just
429 return = Just
446 (>>=) m f = maybe Nothing f m
430 (>>=) m f = maybe Nothing f m
447
431
448− instance Applicative Maybe where
432+ instance applicativeMaybe :: Applicative Maybe where
449 pure = Just
433 pure = Just
450 (<*>) (Just fn) x = fn <$> x
434 (<*>) (Just fn) x = fn <$> x
451 (<*>) Nothing _ = Nothing
435 (<*>) Nothing _ = Nothing
452
436
453− instance Functor Maybe where
437+ instance functorMaybe :: Functor Maybe where
454 (<$>) fn (Just x) = Just (fn x)
438 (<$>) fn (Just x) = Just (fn x)
455 (<$>) _ _ = Nothing
439 (<$>) _ _ = Nothing
456
440
457− instance (Show a) => Show (Maybe a) where
441+ instance showMaybe :: (Show a) => Show (Maybe a) where
458 show (Just x) = "Just " ++ (show x)
442 show (Just x) = "Just " ++ (show x)
459 show Nothing = "Nothing"
443 show Nothing = "Nothing"
460
444
@@ -468,20 +452,20 @@ module Data.Either where
468 either f _ (Left a) = f a
452 either f _ (Left a) = f a
469 either _ g (Right b) = g b
453 either _ g (Right b) = g b
470
454
471− instance Monad (Either e) where
455+ instance monadEither :: Monad (Either e) where
472 return = Right
456 return = Right
473 (>>=) = either (\e _ -> Left e) (\a f -> f a)
457 (>>=) = either (\e _ -> Left e) (\a f -> f a)
474
458
475− instance Applicative (Either e) where
459+ instance applicativeEither :: Applicative (Either e) where
476 pure = Right
460 pure = Right
477 (<*>) (Left e) _ = Left e
461 (<*>) (Left e) _ = Left e
478 (<*>) (Right f) r = f <$> r
462 (<*>) (Right f) r = f <$> r
479
463
480− instance Functor (Either a) where
464+ instance functorEither :: Functor (Either a) where
481 (<$>) _ (Left x) = Left x
465 (<$>) _ (Left x) = Left x
482 (<$>) f (Right y) = Right (f y)
466 (<$>) f (Right y) = Right (f y)
483
467
484− instance (Show a, Show b) => Show (Either a b) where
468+ instance showEither :: (Show a, Show b) => Show (Either a b) where
485 show (Left x) = "Left " ++ (show x)
469 show (Left x) = "Left " ++ (show x)
486 show (Right y) = "Right " ++ (show y)
470 show (Right y) = "Right " ++ (show y)
487
471
@@ -576,7 +560,7 @@ module Data.Array where
576 \ return l1;\
560 \ return l1;\
577 \}" :: forall a. [a] -> [a]
561 \}" :: forall a. [a] -> [a]
578
562
579− foreign import insertAt
563+ foreign import insertAt
580 "function insertAt(index) {\
564 "function insertAt(index) {\
581 \ return function(a) {\
565 \ return function(a) {\
582 \ return function(l) {\
566 \ return function(l) {\
@@ -587,7 +571,7 @@ module Data.Array where
587 \ };\
571 \ };\
588 \}":: forall a. Number -> a -> [a] -> [a]
572 \}":: forall a. Number -> a -> [a] -> [a]
589
573
590− foreign import deleteAt
574+ foreign import deleteAt
591 "function deleteAt(index) {\
575 "function deleteAt(index) {\
592 \ return function(n) {\
576 \ return function(n) {\
593 \ return function(l) {\
577 \ return function(l) {\
@@ -598,7 +582,7 @@ module Data.Array where
598 \ };\
582 \ };\
599 \}":: forall a. Number -> Number -> [a] -> [a]
583 \}":: forall a. Number -> Number -> [a] -> [a]
600
584
601− foreign import updateAt
585+ foreign import updateAt
602 "function updateAt(index) {\
586 "function updateAt(index) {\
603 \ return function(a) {\
587 \ return function(a) {\
604 \ return function(l) {\
588 \ return function(l) {\
@@ -625,7 +609,7 @@ module Data.Array where
625 filter _ [] = []
609 filter _ [] = []
626 filter p (x:xs) | p x = x : filter p xs
610 filter p (x:xs) | p x = x : filter p xs
627 filter p (_:xs) = filter p xs
611 filter p (_:xs) = filter p xs
628−
612+
629 find :: forall a. (a -> Boolean) -> [a] -> Maybe a
613 find :: forall a. (a -> Boolean) -> [a] -> Maybe a
630 find _ [] = Nothing
614 find _ [] = Nothing
631 find p (x:xs) | p x = Just x
615 find p (x:xs) | p x = Just x
@@ -661,20 +645,40 @@ module Data.Array where
661 take _ [] = []
645 take _ [] = []
662 take n (x:xs) = x : take (n - 1) xs
646 take n (x:xs) = x : take (n - 1) xs
663
647
664− instance (Show a) => Show [a] where
648+ instance showArray :: (Show a) => Show [a] where
665 show xs = "[" ++ joinWith (map show xs) "," ++ "]"
649 show xs = "[" ++ joinWith (map show xs) "," ++ "]"
666
650
667− instance Functor [] where
668− (<$>) = map
669−
670− instance Monad [] where
651+ instance monadArray :: Monad [] where
671 return = singleton
652 return = singleton
672 (>>=) = concatMap
653 (>>=) = concatMap
673
654
655+ instance functorArray :: Functor [] where
656+ (<$>) = map
657+
674− instance Alternative [] where
658+ instance alternativeArray :: Alternative [] where
675 empty = []
659 empty = []
676 (<|>) = concat
660 (<|>) = concat
677−
661+
662+module Data.Eq where
663+
664+ import Prelude
665+
666+ -- Referential equality
667+ data Ref a = Ref a
668+
669+ liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
670+ liftRef f (Ref x) (Ref y) = f x y
671+
672+ refEq :: forall a. Ref a -> Ref a -> Boolean
673+ refEq = liftRef unsafeRefEq
674+
675+ refIneq :: forall a. Ref a -> Ref a -> Boolean
676+ refIneq = liftRef unsafeRefIneq
677+
678+ instance eqRef :: Eq (Ref a) where
679+ (==) = refEq
680+ (/=) = refIneq
681+
678module Data.Array.Unsafe where
682module Data.Array.Unsafe where
679
683
680 head :: forall a. [a] -> a
684 head :: forall a. [a] -> a
@@ -690,7 +694,7 @@ module Data.Tuple where
690
694
691 data Tuple a b = Tuple a b
695 data Tuple a b = Tuple a b
692
696
693− instance (Show a, Show b) => Show (Tuple a b) where
697+ instance showTuple :: (Show a, Show b) => Show (Tuple a b) where
694 show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
698 show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
695
699
696 curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
700 curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
@@ -968,7 +972,7 @@ module Control.Monad.Eff where
968 \ return f();\
972 \ return f();\
969 \}" :: forall a. Pure a -> a
973 \}" :: forall a. Pure a -> a
970
974
971− instance Monad (Eff e) where
975+ instance monadEff :: Monad (Eff e) where
972 return = retEff
976 return = retEff
973 (>>=) = bindEff
977 (>>=) = bindEff
974
978
src/Language/PureScript/CodeGen/Optimize.hs+38−48
@@ -46,8 +46,6 @@ import Language.PureScript.Names
46import Language.PureScript.CodeGen.JS.AST
46import Language.PureScript.CodeGen.JS.AST
47import Language.PureScript.Options
47import Language.PureScript.Options
48import Language.PureScript.CodeGen.Common (identToJs)
48import Language.PureScript.CodeGen.Common (identToJs)
49−import Language.PureScript.Sugar.TypeClasses
50− (mkDictionaryValueName)
51import Language.PureScript.Types
49import Language.PureScript.Types
52
50
53-- |
51-- |
@@ -316,10 +314,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
316 prelude = ModuleName [ProperName "Prelude"]
314 prelude = ModuleName [ProperName "Prelude"]
317 effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]
315 effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]
318 -- The name of the type class dictionary for the Monad Eff instance
316 -- The name of the type class dictionary for the Monad Eff instance
319− Right (Ident effDictName) = mkDictionaryValueName
317+ effDictName = "monadEff"
320− effModule
321− (Qualified (Just prelude) (ProperName "Monad"))
322− [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))]
323 -- Check if an expression represents the Monad Eff dictionary
318 -- Check if an expression represents the Monad Eff dictionary
324 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
319 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
325 isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
320 isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
@@ -406,67 +401,62 @@ inlineOperator op f = everywhere (mkT convert)
406
401
407inlineCommonOperators :: JS -> JS
402inlineCommonOperators :: JS -> JS
408inlineCommonOperators = applyAll
403inlineCommonOperators = applyAll
409− [ binary "+" "Num" tyNumber Add
404+ [ binary "numNumber" "+" "Num" tyNumber Add
410− , binary "-" "Num" tyNumber Subtract
405+ , binary "numNumber" "-" "Num" tyNumber Subtract
411− , binary "*" "Num" tyNumber Multiply
406+ , binary "numNumber" "*" "Num" tyNumber Multiply
412− , binary "/" "Num" tyNumber Divide
407+ , binary "numNumber" "/" "Num" tyNumber Divide
413− , binary "%" "Num" tyNumber Modulus
408+ , binary "numNumber" "%" "Num" tyNumber Modulus
414− , unary "negate" "Num" tyNumber Negate
409+ , unary "numNumber" "negate" "Num" tyNumber Negate
415
410
416− , binary "<" "Ord" tyNumber LessThan
411+ , binary "ordNumber" "<" "Ord" tyNumber LessThan
417− , binary ">" "Ord" tyNumber GreaterThan
412+ , binary "ordNumber" ">" "Ord" tyNumber GreaterThan
418− , binary "<=" "Ord" tyNumber LessThanOrEqualTo
413+ , binary "ordNumber" "<=" "Ord" tyNumber LessThanOrEqualTo
419− , binary ">=" "Ord" tyNumber GreaterThanOrEqualTo
414+ , binary "ordNumber" ">=" "Ord" tyNumber GreaterThanOrEqualTo
420
415
421− , binary "==" "Eq" tyNumber EqualTo
416+ , binary "eqNumber" "==" "Eq" tyNumber EqualTo
422− , binary "/=" "Eq" tyNumber NotEqualTo
417+ , binary "eqNumber" "/=" "Eq" tyNumber NotEqualTo
423− , binary "==" "Eq" tyString EqualTo
418+ , binary "eqString" "==" "Eq" tyString EqualTo
424− , binary "/=" "Eq" tyString NotEqualTo
419+ , binary "eqString" "/=" "Eq" tyString NotEqualTo
425− , binary "==" "Eq" tyBoolean EqualTo
420+ , binary "eqBoolean" "==" "Eq" tyBoolean EqualTo
426− , binary "/=" "Eq" tyBoolean NotEqualTo
421+ , binary "eqBoolean" "/=" "Eq" tyBoolean NotEqualTo
427
422
428− , binaryFunction "shl" "Bits" tyNumber ShiftLeft
423+ , binaryFunction "bitsNumber" "shl" "Bits" tyNumber ShiftLeft
429− , binaryFunction "shr" "Bits" tyNumber ShiftRight
424+ , binaryFunction "bitsNumber" "shr" "Bits" tyNumber ShiftRight
430− , binaryFunction "zshr" "Bits" tyNumber ZeroFillShiftRight
425+ , binaryFunction "bitsNumber" "zshr" "Bits" tyNumber ZeroFillShiftRight
431− , binary "&" "Bits" tyNumber BitwiseAnd
426+ , binary "bitsNumber" "&" "Bits" tyNumber BitwiseAnd
432− , binary "|" "Bits" tyNumber BitwiseOr
427+ , binary "bitsNumber" "|" "Bits" tyNumber BitwiseOr
433− , binary "^" "Bits" tyNumber BitwiseXor
428+ , binary "bitsNumber" "^" "Bits" tyNumber BitwiseXor
434− , unary "complement" "Bits" tyNumber BitwiseNot
429+ , unary "bitsNumber" "complement" "Bits" tyNumber BitwiseNot
435
430
436− , binary "&&" "BoolLike" tyBoolean And
431+ , binary "boolLikeBoolean" "&&" "BoolLike" tyBoolean And
437− , binary "||" "BoolLike" tyBoolean Or
432+ , binary "boolLikeBoolean" "||" "BoolLike" tyBoolean Or
438− , unary "not" "BoolLike" tyBoolean Not
433+ , unary "boolLikeBoolean" "not" "BoolLike" tyBoolean Not
439 ]
434 ]
440 where
435 where
441− binary :: String -> String -> Type -> BinaryOperator -> JS -> JS
436+ binary :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
442− binary opString className classTy op = everywhere (mkT convert)
437+ binary dictName opString className classTy op = everywhere (mkT convert)
443 where
438 where
444 convert :: JS -> JS
439 convert :: JS -> JS
445− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
440+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
446 convert other = other
441 convert other = other
447 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
442 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
448 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
443 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
449 isOp _ = False
444 isOp _ = False
450− binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
445+ binaryFunction :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
451− binaryFunction fnName className classTy op = everywhere (mkT convert)
446+ binaryFunction dictName fnName className classTy op = everywhere (mkT convert)
452 where
447 where
453 convert :: JS -> JS
448 convert :: JS -> JS
454− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
449+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
455 convert other = other
450 convert other = other
456 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
451 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
457 isOp _ = False
452 isOp _ = False
458− unary :: String -> String -> Type -> UnaryOperator -> JS -> JS
453+ unary :: String -> String -> String -> Type -> UnaryOperator -> JS -> JS
459− unary fnName className classTy op = everywhere (mkT convert)
454+ unary dictName fnName className classTy op = everywhere (mkT convert)
460 where
455 where
461 convert :: JS -> JS
456 convert :: JS -> JS
462− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x
457+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName className classTy dict = JSUnary op x
463 convert other = other
458 convert other = other
464 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
459 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
465 isOp _ = False
460 isOp _ = False
466− isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
461+ isOpDict dictName className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
467− where
468− Right (Ident dictName) = mkDictionaryValueName
469− (ModuleName [ProperName "Prim"])
470− (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))
471− [ty]
472− isOpDict _ _ _ = False
462+ isOpDict _ _ _ _ = False
src/Language/PureScript/Declarations.hs+1−1
@@ -134,7 +134,7 @@ data Declaration
134 -- |
134 -- |
135 -- A type instance declaration (dependencies, class name, instance type, member declarations)
135 -- A type instance declaration (dependencies, class name, instance type, member declarations)
136 --
136 --
137− | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
137+ | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
138 deriving (Show, D.Data, D.Typeable)
138 deriving (Show, D.Data, D.Typeable)
139
139
140-- |
140-- |
src/Language/PureScript/Parser/Declarations.hs+2−1
@@ -110,6 +110,7 @@ parseTypeClassDeclaration = do
110parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
110parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
111parseTypeInstanceDeclaration = do
111parseTypeInstanceDeclaration = do
112 reserved "instance"
112 reserved "instance"
113+ name <- parseIdent <* lexeme (indented *> P.string "::")
113 deps <- P.optionMaybe $ do
114 deps <- P.optionMaybe $ do
114 deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
115 deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
115 indented
116 indented
@@ -120,7 +121,7 @@ parseTypeInstanceDeclaration = do
120 members <- P.option [] . P.try $ do
121 members <- P.option [] . P.try $ do
121 indented *> reserved "where"
122 indented *> reserved "where"
122 mark (P.many (same *> parseValueDeclaration))
123 mark (P.many (same *> parseValueDeclaration))
123− return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members
124+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
124
125
125-- |
126-- |
126-- Parse a single declaration
127-- Parse a single declaration
src/Language/PureScript/Sugar/CaseDeclarations.hs+2−2
@@ -54,8 +54,8 @@ desugarCases :: [Declaration] -> Either String [Declaration]
54desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
54desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
55 where
55 where
56 desugarRest :: [Declaration] -> Either String [Declaration]
56 desugarRest :: [Declaration] -> Either String [Declaration]
57− desugarRest ((TypeInstanceDeclaration constraints className tys ds) : rest) =
57+ desugarRest ((TypeInstanceDeclaration name constraints className tys ds) : rest) =
58− (:) <$> (TypeInstanceDeclaration constraints className tys <$> desugarCases ds) <*> desugarRest rest
58+ (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
59 desugarRest (d : ds) = (:) d <$> desugarRest ds
59 desugarRest (d : ds) = (:) d <$> desugarRest ds
60 desugarRest [] = pure []
60 desugarRest [] = pure []
61
61
src/Language/PureScript/Sugar/Names.hs+2−2
@@ -152,8 +152,8 @@ renameInModule :: ImportEnvironment -> Module -> Either String Module
152renameInModule imports (Module mn decls) =
152renameInModule imports (Module mn decls) =
153 Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)
153 Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)
154 where
154 where
155− updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =
155+ updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =
156− TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
156+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
157 updateDecl d = return d
157 updateDecl d = return d
158
158
159 updateVars :: Declaration -> Either String Declaration
159 updateVars :: Declaration -> Either String Declaration
src/Language/PureScript/Sugar/TypeClasses.hs+19−37
@@ -16,7 +16,6 @@
16
16
17module Language.PureScript.Sugar.TypeClasses (
17module Language.PureScript.Sugar.TypeClasses (
18 desugarTypeClasses,
18 desugarTypeClasses,
19− mkDictionaryValueName,
20 mkDictionaryEntryName
19 mkDictionaryEntryName
21) where
20) where
22
21
@@ -93,10 +92,10 @@ desugarDecl mn d@(TypeClassDeclaration name args members) = do
93 let tys = map memberToNameAndType members
92 let tys = map memberToNameAndType members
94 modify (M.insert (mn, name) (args, tys))
93 modify (M.insert (mn, name) (args, tys))
95 return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members
94 return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members
96−desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
95+desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
97 desugared <- lift $ desugarCases members
96 desugared <- lift $ desugarCases members
98− entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
97+ entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
99− dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared
98+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
100 return $ d : entries ++ [dictDecl]
99 return $ d : entries ++ [dictDecl]
101desugarDecl _ other = return [other]
100desugarDecl _ other = return [other]
102
101
@@ -115,69 +114,52 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
115 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
114 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
116typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
115typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
117
116
118−typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
117+typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
119−typeInstanceDictionaryDeclaration mn deps name tys decls = do
118+typeInstanceDictionaryDeclaration name mn deps className tys decls = do
120 m <- get
119 m <- get
121− (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
120+ (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right
122− $ M.lookup (qualify mn name) m
121+ $ M.lookup (qualify mn className) m
123 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
122 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
124− entryName <- lift $ mkDictionaryValueName mn name tys
123+ let entryName = Escaped (show name)
125 memberNames <- mapM (memberToNameAndValue memberTypes) decls
124 memberNames <- mapM (memberToNameAndValue memberTypes) decls
126 return $ ValueDeclaration entryName [] Nothing
125 return $ ValueDeclaration entryName [] Nothing
127 (TypedValue True
126 (TypedValue True
128 (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
127 (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
129 (quantify (if null deps then
128 (quantify (if null deps then
130− function unit (foldl TypeApp (TypeConstructor name) tys)
129+ function unit (foldl TypeApp (TypeConstructor className) tys)
131 else
130 else
132− foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps))
131+ foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))
133 )
132 )
134 where
133 where
135 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
134 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
136 memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do
135 memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do
137 memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'
136 memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'
138− memberName <- mkDictionaryEntryName mn name tys ident
137+ memberName <- mkDictionaryEntryName name ident
139 return (identToJs ident, TypedValue False
138 return (identToJs ident, TypedValue False
140 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
139 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
141 (quantify memberType))
140 (quantify memberType))
142 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
141 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
143
142
144−typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
143+typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
145−typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident [] _ val) = do
144+typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident [] _ val) = do
146 m <- get
145 m <- get
147 valTy <- lift $ do (args, members) <- lookupTypeClass m
146 valTy <- lift $ do (args, members) <- lookupTypeClass m
148 ty' <- lookupIdent members
147 ty' <- lookupIdent members
149 return $ replaceAllTypeVars (zip args tys) ty'
148 return $ replaceAllTypeVars (zip args tys) ty'
150− entryName <- mkDictionaryEntryName mn name tys ident
149+ entryName <- mkDictionaryEntryName name ident
151 return $ ValueDeclaration entryName [] Nothing
150 return $ ValueDeclaration entryName [] Nothing
152 (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
151 (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
153 where
152 where
154− lookupTypeClass m = maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn name) m
153+ lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m
155− lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
154+ lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
156−typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
155+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
157
156
158qualifiedToString :: ModuleName -> Qualified ProperName -> String
157qualifiedToString :: ModuleName -> Qualified ProperName -> String
159qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
158qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
160
159
161−
162−-- |
163−-- Generate a name for a type class dictionary, based on the module name, class name and type name
164−--
165−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident
166−mkDictionaryValueName mn cl tys = do
167− tyStr <- mapM (typeToString mn) tys
168− return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr
169−
170−typeToString :: ModuleName -> Type -> Either String String
171−typeToString _ (TypeVar _) = return "var"
172−typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
173−typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
174−typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"
175−
176-- |
160-- |
177-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
161-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
178-- member name
162-- member name
179--
163--
180−mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident
164+mkDictionaryEntryName :: Ident -> Ident -> Desugar Ident
181−mkDictionaryEntryName mn name tys ident = do
182− Ident dictName <- lift $ mkDictionaryValueName mn name tys
183− return $ Escaped $ dictName ++ "_" ++ identToJs ident
165+mkDictionaryEntryName dictName ident = return $ Escaped $ show dictName ++ "_" ++ identToJs ident
src/Language/PureScript/TypeChecker.hs+1−2
@@ -184,9 +184,8 @@ typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
184 env <- getEnv
184 env <- getEnv
185 ds <- typeCheckAll mainModuleName moduleName rest
185 ds <- typeCheckAll mainModuleName moduleName rest
186 return $ d : ds
186 return $ d : ds
187−typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do
187+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
188 env <- getEnv
188 env <- getEnv
189− dictName <- Check . lift $ mkDictionaryValueName moduleName className tys
190 mapM_ (checkTypeClassInstance moduleName) tys
189 mapM_ (checkTypeClassInstance moduleName) tys
191 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
190 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
192 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
191 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]