git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'superclasses'
e62efe1Phil Freeman
docgen/Main.hs+7−4
compare with golang
unifiedsplit
@@ -92,7 +92,7 @@ isExported (Just exps) decl = any (matches decl) exps
92 matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
92 matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
93 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
93 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
94 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
94 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
95− matches (P.TypeClassDeclaration ident _ _) (P.TypeClassRef ident') = ident == ident'
95+ matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
96 matches (P.PositionedDeclaration _ d) r = d `matches` r
96 matches (P.PositionedDeclaration _ d) r = d `matches` r
97 matches _ _ = False
97 matches _ _ = False
98
98
@@ -124,8 +124,11 @@ renderDeclaration n _ (P.ExternDataDeclaration name kind) =
124renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
124renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
125 let typeName = P.runProperName name ++ " " ++ unwords args
125 let typeName = P.runProperName name ++ " " ++ unwords args
126 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
126 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
127−renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do
127+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
128+ let impliesText = case implies of
129+ [] -> ""
130+ is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
128− atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
131+ atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"
129 mapM_ (renderDeclaration (n + 2) exps) ds
132 mapM_ (renderDeclaration (n + 2) exps) ds
130renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
133renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
131 let constraintsText = case constraints of
134 let constraintsText = case constraints of
@@ -142,7 +145,7 @@ getName (P.ExternDeclaration _ ident _ _) = show ident
142getName (P.DataDeclaration name _ _) = P.runProperName name
145getName (P.DataDeclaration name _ _) = P.runProperName name
143getName (P.ExternDataDeclaration name _) = P.runProperName name
146getName (P.ExternDataDeclaration name _) = P.runProperName name
144getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
147getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
145−getName (P.TypeClassDeclaration name _ _) = P.runProperName name
148+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
146getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
149getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
147getName (P.PositionedDeclaration _ d) = getName d
150getName (P.PositionedDeclaration _ d) = getName d
148getName _ = error "Invalid argument to getName"
151getName _ = error "Invalid argument to getName"
examples/failing/Superclasses1.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+class Su a where
4+ su :: a -> a
5+
6+class (Su a) <= Cl a where
7+ cl :: a -> a -> a
8+
9+instance clNumber :: Cl Number where
10+ cl n m = n + m
11+
examples/failing/Superclasses2.pursnew file+9
@@ -0,0 +1,9 @@
1+module CycleInSuperclasses where
2+
3+class (Foo a) <= Bar a
4+
5+class (Bar a) <= Foo a
6+
7+instance barString :: Bar String
8+
9+instance fooString :: Foo String
examples/failing/Superclasses3.pursnew file+5
@@ -0,0 +1,5 @@
1+module UnknownSuperclassTypeVar where
2+
3+class Foo a
4+
5+class (Foo b) <= Bar a
examples/failing/Superclasses4.pursnew file+12
@@ -0,0 +1,12 @@
1+module OverlappingInstances where
2+
3+class Foo a
4+
5+instance foo1 :: Foo Number
6+
7+instance foo2 :: Foo Number
8+
9+test :: forall a. (Foo a) => a -> a
10+test a = a
11+
12+test1 = test 0
examples/passing/Do.purs+12−9
@@ -8,17 +8,20 @@ instance functorMaybe :: Functor Maybe where
8 (<$>) f Nothing = Nothing
8 (<$>) f Nothing = Nothing
9 (<$>) f (Just x) = Just (f x)
9 (<$>) f (Just x) = Just (f x)
10
10
11−instance applicativeMaybe :: Applicative Maybe where
11+instance applyMaybe :: Apply Maybe where
12− pure = Just
13 (<*>) (Just f) (Just x) = Just (f x)
12 (<*>) (Just f) (Just x) = Just (f x)
14 (<*>) _ _ = Nothing
13 (<*>) _ _ = Nothing
15
14
16−instance monadMaybe :: Prelude.Monad Maybe where
15+instance applicativeMaybe :: Applicative Maybe where
17− return = Just
16+ pure = Just
17+
18+instance bindMaybe :: Bind Maybe where
18 (>>=) Nothing _ = Nothing
19 (>>=) Nothing _ = Nothing
19 (>>=) (Just a) f = f a
20 (>>=) (Just a) f = f a
20
21
22+instance monadMaybe :: Prelude.Monad Maybe
23+
21−test1 = \_ -> do
24+test1 = \_ -> do
22 Just "abc"
25 Just "abc"
23
26
24test2 = \_ -> do
27test2 = \_ -> do
@@ -43,14 +46,14 @@ test5 mx my mz = do
43 z <- mz
46 z <- mz
44 Just (z + sum + 1)
47 Just (z + sum + 1)
45
48
46−test6 mx = \_ -> do
49+test6 mx = \_ -> do
47− let
50+ let
48 f :: forall a. Maybe a -> a
51 f :: forall a. Maybe a -> a
49 f (Just x) = x
52 f (Just x) = x
50 Just (f mx)
53 Just (f mx)
51
54
52−test8 = \_ -> do
55+test8 = \_ -> do
53− Just (do
56+ Just (do
54 Just 1)
57 Just 1)
55
58
56test9 = \_ -> (+) <$> Just 1 <*> Just 2
59test9 = \_ -> (+) <$> Just 1 <*> Just 2
examples/passing/EqOrd.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+data Pair a b = Pair a b
4+
5+instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
6+ compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
7+ EQ -> compare b1 b2
8+ r -> r
9+
10+instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
11+ (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
12+ (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
13+
14+main = Debug.Trace.print $ Pair 1 2 == Pair 1 2
examples/passing/MonadState.purs+12−2
@@ -12,11 +12,21 @@ data State s a = State (s -> Tuple s a)
12
12
13runState s (State f) = f s
13runState s (State f) = f s
14
14
15−instance monadState :: Prelude.Monad (State s) where
15+instance functorState :: Functor (State s) where
16+ (<$>) = liftM1
17+
18+instance applyState :: Apply (State s) where
19+ (<*>) = ap
20+
21+instance applicativeState :: Applicative (State s) where
16− return a = State $ \s -> Tuple s a
22+ pure a = State $ \s -> Tuple s a
23+
24+instance bindState :: Bind (State s) where
17 (>>=) f g = State $ \s -> case runState s f of
25 (>>=) f g = State $ \s -> case runState s f of
18 Tuple s1 a -> runState s1 (g a)
26 Tuple s1 a -> runState s1 (g a)
19
27
28+instance monadState :: Monad (State s)
29+
20instance monadStateState :: MonadState s (State s) where
30instance monadStateState :: MonadState s (State s) where
21 get = State (\s -> Tuple s s)
31 get = State (\s -> Tuple s s)
22 put s = State (\_ -> Tuple s {})
32 put s = State (\_ -> Tuple s {})
examples/passing/Operators.purs+4−2
@@ -3,6 +3,7 @@ module Main where
3 import Control.Monad.Eff
3 import Control.Monad.Eff
4 import Debug.Trace
4 import Debug.Trace
5
5
6+ bar :: String -> String -> String
6 bar = \s1 s2 -> s1 ++ s2
7 bar = \s1 s2 -> s1 ++ s2
7
8
8 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
9 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
@@ -25,9 +26,10 @@ module Main where
25
26
26 test6 = ((\x -> x) `k` 2) 3
27 test6 = ((\x -> x) `k` 2) 3
27
28
29+ (<+>) :: String -> String -> String
28− (<>) = \s1 s2 -> s1 ++ s2
30+ (<+>) = \s1 s2 -> s1 ++ s2
29
31
30− test7 = "Hello" <> "World!"
32+ test7 = "Hello" <+> "World!"
31
33
32 (@@) :: forall a b. (a -> b) -> a -> b
34 (@@) :: forall a b. (a -> b) -> a -> b
33 (@@) = \f x -> f x
35 (@@) = \f x -> f x
examples/passing/Superclasses1.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+class Su a where
4+ su :: a -> a
5+
6+class (Su a) <= Cl a where
7+ cl :: a -> a -> a
8+
9+instance suNumber :: Su Number where
10+ su n = n + 1
11+
12+instance clNumber :: Cl Number where
13+ cl n m = n + m
14+
15+test :: forall a. (Cl a) => a -> a
16+test a = su (cl a a)
17+
18+main = Debug.Trace.print $ test 10
examples/passing/Superclasses2.pursnew file+21
@@ -0,0 +1,21 @@
1+module Main where
2+
3+class Su a where
4+ su :: a -> a
5+
6+class (Su [a]) <= Cl a where
7+ cl :: a -> a -> a
8+
9+instance suNumber :: Su Number where
10+ su n = n + 1
11+
12+instance suArray :: (Su a) => Su [a] where
13+ su (x : _) = [su x]
14+
15+instance clNumber :: Cl Number where
16+ cl n m = n + m
17+
18+test :: forall a. (Cl a) => a -> [a]
19+test x = su [cl x x]
20+
21+main = Debug.Trace.print $ test 10 !! 0
examples/passing/Superclasses3.pursnew file+41
@@ -0,0 +1,41 @@
1+module Main where
2+
3+import Debug.Trace
4+
5+import Control.Monad.Eff
6+
7+class (Monad m) <= MonadWriter w m where
8+ tell :: w -> m {}
9+
10+testFunctor :: forall m. (Monad m) => m Number -> m Number
11+testFunctor n = (+) 1 <$> n
12+
13+test :: forall w m. (Monad m, MonadWriter w m) => w -> m {}
14+test w = do
15+ tell w
16+ tell w
17+ tell w
18+
19+data MTrace a = MTrace (Eff (trace :: Trace) a)
20+
21+runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
22+runMTrace (MTrace a) = a
23+
24+instance functorMTrace :: Functor MTrace where
25+ (<$>) = liftM1
26+
27+instance applyMTrace :: Apply MTrace where
28+ (<*>) = ap
29+
30+instance applicativeMTrace :: Applicative MTrace where
31+ pure = MTrace <<< return
32+
33+instance bindMTrace :: Bind MTrace where
34+ (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))
35+
36+instance monadMTrace :: Monad MTrace
37+
38+instance writerMTrace :: MonadWriter String MTrace where
39+ tell s = MTrace (trace s)
40+
41+main = runMTrace $ test "Done"
examples/passing/TypeClasses.purs+37−7
@@ -21,17 +21,37 @@ instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
21
21
22test3 = \_ -> show (Data "testing")
22test3 = \_ -> show (Data "testing")
23
23
24−instance monadData :: Prelude.Monad Data where
24+instance functorData :: Functor Data where
25− return = Data
25+ (<$>) = liftM1
26+
27+instance applyData :: Apply Data where
28+ (<*>) = ap
29+
30+instance applicativeData :: Applicative Data where
31+ pure = Data
32+
33+instance bindData :: Bind Data where
26 (>>=) (Data a) f = f a
34 (>>=) (Data a) f = f a
27
35
36+instance monadData :: Monad Data
37+
28data Maybe a = Nothing | Just a
38data Maybe a = Nothing | Just a
29
39
30−instance monadMaybe :: Prelude.Monad Maybe where
40+instance functorMaybe :: Functor Maybe where
41+ (<$>) = liftM1
42+
43+instance applyMaybe :: Apply Maybe where
44+ (<*>) = ap
45+
46+instance applicativeMaybe :: Applicative Maybe where
31− return = Just
47+ pure = Just
48+
49+instance bindMaybe :: Bind Maybe where
32 (>>=) Nothing _ = Nothing
50 (>>=) Nothing _ = Nothing
33 (>>=) (Just a) f = f a
51 (>>=) (Just a) f = f a
34
52
53+instance monadMaybe :: Monad Maybe
54+
35test4 :: forall a m. (Monad m) => a -> m Number
55test4 :: forall a m. (Monad m) => a -> m Number
36test4 = \_ -> return 1
56test4 = \_ -> return 1
37
57
@@ -43,10 +63,20 @@ instance showArray :: (Prelude.Show a) => Prelude.Show [a] where
43
63
44test6 = \_ -> show ["testing"]
64test6 = \_ -> show ["testing"]
45
65
46−instance monadFunction :: Prelude.Monad ((->) r) where
66+instance functorFunction :: Functor ((->) r) where
47− return a r = a
67+ (<$>) = liftM1
68+
69+instance applyFunction :: Apply ((->) r) where
70+ (<*>) = ap
71+
72+instance applicativeFunction :: Applicative ((->) r) where
73+ pure a _ = a
74+
75+instance bindFunction :: Bind ((->) r) where
48 (>>=) f g r = g (f r) r
76 (>>=) f g r = g (f r) r
49
77
78+instance monadFunction :: Monad ((->) r)
79+
50ask r = r
80ask r = r
51
81
52runReader r f = f r
82runReader r f = f r
@@ -54,6 +84,6 @@ runReader r f = f r
54test9 _ = runReader 0 $ do
84test9 _ = runReader 0 $ do
55 n <- ask
85 n <- ask
56 return $ n + 1
86 return $ n + 1
57−
87+
58main = Debug.Trace.trace (test7 "Done")
88main = Debug.Trace.trace (test7 "Done")
59
89
prelude/prelude.purs+48−27
@@ -59,10 +59,12 @@ module Prelude where
59
59
60 infixl 4 <*>
60 infixl 4 <*>
61
61
62− class Applicative f where
62+ class (Functor f) <= Apply f where
63− pure :: forall a. a -> f a
64 (<*>) :: forall a b. f (a -> b) -> f a -> f b
63 (<*>) :: forall a b. f (a -> b) -> f a -> f b
65
64
65+ class (Apply f) <= Applicative f where
66+ pure :: forall a. a -> f a
67+
66 liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
68 liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
67 liftA1 f a = pure f <*> a
69 liftA1 f a = pure f <*> a
68
70
@@ -74,10 +76,14 @@ module Prelude where
74
76
75 infixl 1 >>=
77 infixl 1 >>=
76
78
77− class Monad m where
79+ class (Apply m) <= Bind m where
78− return :: forall a. a -> m a
79 (>>=) :: forall a b. m a -> (a -> m b) -> m b
80 (>>=) :: forall a b. m a -> (a -> m b) -> m b
80
81
82+ class (Applicative m, Bind m) <= Monad m
83+
84+ return :: forall m a. (Monad m) => a -> m a
85+ return = pure
86+
81 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
87 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
82 liftM1 f a = do
88 liftM1 f a = do
83 a' <- a
89 a' <- a
@@ -199,7 +205,7 @@ module Prelude where
199 show GT = "GT"
205 show GT = "GT"
200 show EQ = "EQ"
206 show EQ = "EQ"
201
207
202− class Ord a where
208+ class (Eq a) <= Ord a where
203 compare :: a -> a -> Ordering
209 compare :: a -> a -> Ordering
204
210
205 infixl 4 <
211 infixl 4 <
@@ -339,13 +345,25 @@ module Prelude where
339 (||) = boolOr
345 (||) = boolOr
340 not = boolNot
346 not = boolNot
341
347
348+ infixr 5 <>
349+
350+ class Semigroup a where
351+ (<>) :: a -> a -> a
352+
353+ foreign import concatString
354+ "function concatString(s1) {\
355+ \ return function(s2) {\
356+ \ return s1 + s2;\
357+ \ };\
358+ \}" :: String -> String -> String
359+
360+ instance semigroupString :: Semigroup String where
361+ (<>) = concatString
362+
342 infixr 5 ++
363 infixr 5 ++
343
364
344− foreign import (++) "function $plus$plus(s1) {\
365+ (++) :: forall s. (Semigroup s) => s -> s -> s
345− \ return function(s2) {\
366+ (++) = (<>)
346− \ return s1 + s2;\
347− \ };\
348− \}" :: String -> String -> String
349
367
350module Data.Eq where
368module Data.Eq where
351
369
@@ -362,19 +380,19 @@ module Control.Monad.Eff where
362
380
363 foreign import data Eff :: # ! -> * -> *
381 foreign import data Eff :: # ! -> * -> *
364
382
365− foreign import retEff "function retEff(a) {\
383+ foreign import returnE "function returnE(a) {\
366− \ return function() {\
367− \ return a;\
368− \ };\
369− \}" :: forall e a. a -> Eff e a
370−
371− foreign import bindEff "function bindEff(a) {\
372− \ return function(f) {\
384+ \ return function() {\
373− \ return function() {\
385+ \ return a;\
374− \ return f(a())();\
375− \ };\
376 \ };\
386 \ };\
387+ \}" :: forall e a. a -> Eff e a
388+
389+ foreign import bindE "function bindE(a) {\
390+ \ return function(f) {\
391+ \ return function() {\
392+ \ return f(a())();\
393+ \ };\
394+ \ };\
377− \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
395+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
378
396
379 type Pure a = forall e. Eff e a
397 type Pure a = forall e. Eff e a
380
398
@@ -385,13 +403,16 @@ module Control.Monad.Eff where
385 instance functorEff :: Functor (Eff e) where
403 instance functorEff :: Functor (Eff e) where
386 (<$>) = liftA1
404 (<$>) = liftA1
387
405
388− instance applicativeEff :: Applicative (Eff e) where
406+ instance applyEff :: Apply (Eff e) where
389− pure = return
390 (<*>) = ap
407 (<*>) = ap
391
408
409+ instance applicativeEff :: Applicative (Eff e) where
410+ pure = returnE
411+
412+ instance bindEff :: Bind (Eff e) where
413+ (>>=) = bindE
414+
392− instance monadEff :: Monad (Eff e) where
415+ instance monadEff :: Monad (Eff e)
393− return = retEff
394− (>>=) = bindEff
395
416
396 foreign import untilE "function untilE(f) {\
417 foreign import untilE "function untilE(f) {\
397 \ return function() {\
418 \ return function() {\
purescript.cabal+1−1
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.4.16
2+version: 0.4.17
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Custom
4build-type: Custom
5license: MIT
5license: MIT
src/Language/PureScript/CodeGen/Externs.hs+4−2
@@ -77,10 +77,12 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
77 exportToPs (TypeClassRef className) =
77 exportToPs (TypeClassRef className) =
78 case Qualified (Just moduleName) className `M.lookup` typeClasses env of
78 case Qualified (Just moduleName) className `M.lookup` typeClasses env of
79 Nothing -> error $ show className ++ " has no type class definition in exportToPs"
79 Nothing -> error $ show className ++ " has no type class definition in exportToPs"
80− Just (args, members) -> do
80+ Just (args, members, implies) -> do
81+ let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
81− tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]
82+ tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]
82 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
83 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
83 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
84 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
85+
84 exportToPs (TypeInstanceRef ident) = do
86 exportToPs (TypeInstanceRef ident) = do
85 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
87 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
86 fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
88 fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
src/Language/PureScript/CodeGen/JS.hs+1−1
@@ -144,7 +144,7 @@ valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntim
144valueToJs _ m _ (Var ident) = varToJs m ident
144valueToJs _ m _ (Var ident) = varToJs m ident
145valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
145valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
146valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
146valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
147−valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
147+valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
148valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
148valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
149
149
150-- |
150-- |
src/Language/PureScript/Constants.hs+9
@@ -146,6 +146,9 @@ pokeSTArray = "pokeSTArray"
146monadEffDictionary :: String
146monadEffDictionary :: String
147monadEffDictionary = "monadEff"
147monadEffDictionary = "monadEff"
148
148
149+bindEffDictionary :: String
150+bindEffDictionary = "bindEff"
151+
149numNumber :: String
152numNumber :: String
150numNumber = "numNumber"
153numNumber = "numNumber"
151
154
@@ -167,6 +170,9 @@ bitsNumber = "bitsNumber"
167boolLikeBoolean :: String
170boolLikeBoolean :: String
168boolLikeBoolean = "boolLikeBoolean"
171boolLikeBoolean = "boolLikeBoolean"
169
172
173+semigroupString :: String
174+semigroupString = "semigroupString"
175+
170-- Main module
176-- Main module
171
177
172main :: String
178main :: String
@@ -177,6 +183,9 @@ main = "main"
177_ps :: String
183_ps :: String
178_ps = "_ps"
184_ps = "_ps"
179
185
186+__superclasses :: String
187+__superclasses = "__superclasses"
188+
180-- Modules
189-- Modules
181
190
182prim :: String
191prim :: String
src/Language/PureScript/Declarations.hs+9−4
@@ -158,9 +158,9 @@ data Declaration
158 --
158 --
159 | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)
159 | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)
160 -- |
160 -- |
161− -- A type class declaration (name, argument, member declarations)
161+ -- A type class declaration (name, argument, implies, member declarations)
162 --
162 --
163− | TypeClassDeclaration ProperName [String] [Declaration]
163+ | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]
164 -- |
164 -- |
165 -- A type instance declaration (name, dependencies, class name, instance types, member
165 -- A type instance declaration (name, dependencies, class name, instance types, member
166 -- declarations)
166 -- declarations)
@@ -329,10 +329,15 @@ data Value
329 -- |
329 -- |
330 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
330 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
331 -- placeholders will be replaced with actual expressions representing type classes dictionaries which
331 -- placeholders will be replaced with actual expressions representing type classes dictionaries which
332− -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
332+ -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
333+ -- at superclass implementations when searching for a dictionary, the type class name and
333 -- instance type, and the type class dictionaries in scope.
334 -- instance type, and the type class dictionaries in scope.
334 --
335 --
335− | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
336+ | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
337+ -- |
338+ -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
339+ --
340+ | SuperClassDictionary (Qualified ProperName) [Type]
336 -- |
341 -- |
337 -- A value with source position information
342 -- A value with source position information
338 --
343 --
src/Language/PureScript/Environment.hs+1−1
@@ -53,7 +53,7 @@ data Environment = Environment {
53 -- |
53 -- |
54 -- Type classes
54 -- Type classes
55 --
55 --
56− , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])
56+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])
57 } deriving (Show)
57 } deriving (Show)
58
58
59-- |
59-- |
src/Language/PureScript/Optimizer.hs−1
@@ -66,7 +66,6 @@ optimize opts | optionsNoOptimizations opts = id
66 , inlineOperator (C.$) $ \f x -> JSApp f [x]
66 , inlineOperator (C.$) $ \f x -> JSApp f [x]
67 , inlineOperator (C.#) $ \x f -> JSApp f [x]
67 , inlineOperator (C.#) $ \x f -> JSApp f [x]
68 , inlineOperator (C.!!) $ flip JSIndexer
68 , inlineOperator (C.!!) $ flip JSIndexer
69− , inlineOperator (C.++) $ JSBinary Add
70 , inlineCommonOperators ])
69 , inlineCommonOperators ])
71
70
72untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
71untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
src/Language/PureScript/Optimizer/Inliner.hs+2
@@ -110,6 +110,8 @@ inlineCommonOperators = applyAll
110 , binary C.eqBoolean (C.==) EqualTo
110 , binary C.eqBoolean (C.==) EqualTo
111 , binary C.eqBoolean (C./=) NotEqualTo
111 , binary C.eqBoolean (C./=) NotEqualTo
112
112
113+ , binary C.semigroupString (C.++) Add
114+
113 , binaryFunction C.bitsNumber C.shl ShiftLeft
115 , binaryFunction C.bitsNumber C.shl ShiftLeft
114 , binaryFunction C.bitsNumber C.shr ShiftRight
116 , binaryFunction C.bitsNumber C.shr ShiftRight
115 , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
117 , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
src/Language/PureScript/Optimizer/MagicDo.hs+7−7
@@ -74,10 +74,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
74 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
74 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
75 convert other = other
75 convert other = other
76 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
76 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
77− isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
77+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
78 isBind _ = False
78 isBind _ = False
79 -- Check if an expression represents a monomorphic call to return for the Eff monad
79 -- Check if an expression represents a monomorphic call to return for the Eff monad
80− isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
80+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
81 isReturn _ = False
81 isReturn _ = False
82 -- Check if an expression represents the polymorphic >>= function
82 -- Check if an expression represents the polymorphic >>= function
83 isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
83 isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
@@ -101,11 +101,11 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
101 name == name' = True
101 name == name' = True
102 isEffFunc _ _ = False
102 isEffFunc _ _ = False
103 -- Check if an expression represents the Monad Eff dictionary
103 -- Check if an expression represents the Monad Eff dictionary
104− isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True
104+ isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True
105− isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
105+ isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
106− _ps == C._ps &&
106+ _ps == C._ps &&
107− prop == C.monadEffDictionary = True
107+ prop == name = True
108− isEffDict _ = False
108+ isEffDict _ _ = False
109 -- Remove __do function applications which remain after desugaring
109 -- Remove __do function applications which remain after desugaring
110 undo :: JS -> JS
110 undo :: JS -> JS
111 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
111 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
src/Language/PureScript/Parser/Declarations.hs+6−1
@@ -144,12 +144,17 @@ parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
145parseTypeClassDeclaration = do
145parseTypeClassDeclaration = do
146 reserved "class"
146 reserved "class"
147+ implies <- P.option [] $ do
148+ indented
149+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
150+ reservedOp "<="
151+ return implies
147 className <- indented *> properName
152 className <- indented *> properName
148 idents <- P.many (indented *> identifier)
153 idents <- P.many (indented *> identifier)
149 members <- P.option [] . P.try $ do
154 members <- P.option [] . P.try $ do
150 indented *> reserved "where"
155 indented *> reserved "where"
151 mark (P.many (same *> positioned parseTypeDeclaration))
156 mark (P.many (same *> positioned parseTypeDeclaration))
152− return $ TypeClassDeclaration className idents members
157+ return $ TypeClassDeclaration className idents implies members
153
158
154parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
159parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
155parseTypeInstanceDeclaration = do
160parseTypeInstanceDeclaration = do
src/Language/PureScript/Pretty/Types.hs+1−1
@@ -39,7 +39,7 @@ typeLiterals = mkPattern match
39 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
39 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
40 match (TypeConstructor ctor) = Just $ show ctor
40 match (TypeConstructor ctor) = Just $ show ctor
41 match (TUnknown (Unknown u)) = Just $ 'u' : show u
41 match (TUnknown (Unknown u)) = Just $ 'u' : show u
42− match (Skolem s _) = Just $ 's' : show s
42+ match (Skolem name s _) = Just $ name ++ show s
43 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
43 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
44 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
44 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
45 match REmpty = Just "()"
45 match REmpty = Just "()"
src/Language/PureScript/Pretty/Values.hs+2−1
@@ -73,7 +73,8 @@ literals = mkPattern' match
73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
74 , currentIndent
74 , currentIndent
75 ]
75 ]
76− match (TypeClassDictionary _ _) = return "<<dict>>"
76+ match (TypeClassDictionary _ _ _) = return "<<dict>>"
77+ match (SuperClassDictionary _ _) = return "<<superclass dict>>"
77 match (TypedValue _ val _) = prettyPrintValue' val
78 match (TypedValue _ val _) = prettyPrintValue' val
78 match (PositionedValue _ val) = prettyPrintValue' val
79 match (PositionedValue _ val) = prettyPrintValue' val
79 match _ = mzero
80 match _ = mzero
src/Language/PureScript/Sugar/Names.hs+7−5
@@ -185,6 +185,8 @@ renameInModule imports exports (Module mn decls exps) =
185 go (TypeSynonymDeclaration name ps ty) =
185 go (TypeSynonymDeclaration name ps ty) =
186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $
186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $
187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
188+ go (TypeClassDeclaration className args implies ds) =
189+ TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds
188 go (TypeInstanceDeclaration name cs cn ts ds) =
190 go (TypeInstanceDeclaration name cs cn ts ds) =
189 TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds
191 TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds
190 go (ExternInstanceDeclaration name cs cn ts) =
192 go (ExternInstanceDeclaration name cs cn ts) =
@@ -209,7 +211,7 @@ renameInModule imports exports (Module mn decls exps) =
209 bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
211 bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
210 (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
212 (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
211 bindFunctionArgs pb other = return (pb, other)
213 bindFunctionArgs pb other = return (pb, other)
212−
214+
213 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
215 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
214 bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
216 bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
215
217
@@ -245,7 +247,7 @@ renameInModule imports exports (Module mn decls exps) =
245 updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)
247 updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)
246 updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)
248 updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)
247 updateType pos t = return (pos, t)
249 updateType pos t = return (pos, t)
248−
250+
249 updateType' :: Data d => d -> Either ErrorStack d
251 updateType' :: Data d => d -> Either ErrorStack d
250 updateType' = everywhereWithContextM' Nothing (mkS updateType)
252 updateType' = everywhereWithContextM' Nothing (mkS updateType)
251
253
@@ -301,7 +303,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
301
303
302 -- Add a declaration from a module to the global export environment
304 -- Add a declaration from a module to the global export environment
303 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
305 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
304− addDecl mn env (TypeClassDeclaration tcn _ ds) = do
306+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
305 env' <- addTypeClass env mn tcn
307 env' <- addTypeClass env mn tcn
306 foldM go env' ds
308 foldM go env' ds
307 where
309 where
@@ -393,14 +395,14 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron
393resolveImports env (Module currentModule decls _) =
395resolveImports env (Module currentModule decls _) =
394 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
396 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
395 where
397 where
396−
398+
397 -- A Map from module name to the source position for the import, the list of imports from that
399 -- A Map from module name to the source position for the import, the list of imports from that
398 -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
400 -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
399 -- for the module
401 -- for the module
400 scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
402 scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
401 scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
403 scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
402
404
403− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
405+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
404 resolveImport' imp (mn, (pos, explImports, impQual)) = do
406 resolveImport' imp (mn, (pos, explImports, impQual)) = do
405 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
407 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
406 positioned $ resolveImport currentModule mn modExports imp impQual explImports
408 positioned $ resolveImport currentModule mn modExports imp impQual explImports
src/Language/PureScript/Sugar/TypeClasses.hs+55−14
@@ -27,6 +27,8 @@ import Language.PureScript.Environment
27import Language.PureScript.Errors
27import Language.PureScript.Errors
28import Language.PureScript.CodeGen.Common (identToJs)
28import Language.PureScript.CodeGen.Common (identToJs)
29
29
30+import qualified Language.PureScript.Constants as C
31+
30import Control.Applicative
32import Control.Applicative
31import Control.Monad.State
33import Control.Monad.State
32import Control.Arrow (first, second)
34import Control.Arrow (first, second)
@@ -34,7 +36,7 @@ import Data.Maybe (catMaybes)
34
36
35import qualified Data.Map as M
37import qualified Data.Map as M
36
38
37−type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])
39+type MemberMap = M.Map (ModuleName, ProperName) Declaration
38
40
39type Desugar = StateT MemberMap (Either ErrorStack)
41type Desugar = StateT MemberMap (Either ErrorStack)
40
42
@@ -70,6 +72,14 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
70-- instance fooArray :: (Foo a) => Foo [a] where
72-- instance fooArray :: (Foo a) => Foo [a] where
71-- foo = map foo
73-- foo = map foo
72--
74--
75+-- {- Superclasses -}
76+--
77+-- class (Foo a) <= Sub a where
78+-- sub :: a
79+--
80+-- instance subString :: Sub String where
81+-- sub = ""
82+--
73-- becomes
83-- becomes
74--
84--
75-- type Foo a = { foo :: a -> a }
85-- type Foo a = { foo :: a -> a }
@@ -84,11 +94,22 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
84-- fooArray :: forall a. (Foo a) => Foo [a]
94-- fooArray :: forall a. (Foo a) => Foo [a]
85-- fooArray = { foo: map foo }
95-- fooArray = { foo: map foo }
86--
96--
97+-- {- Superclasses -}
98+--
99+-- ...
100+--
101+-- subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }
102+-- subString _ = {
103+-- __superclasses: {
104+-- "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>
105+-- }
106+-- sub: ""
107+-- }
108+--
87desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
109desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
88−desugarDecl mn d@(TypeClassDeclaration name args members) = do
110+desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
89− let tys = map memberToNameAndType members
90− modify (M.insert (mn, name) (args, tys))
111+ modify (M.insert (mn, name) d)
91− return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
112+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
92desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
113desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
93 desugared <- lift $ desugarCases members
114 desugared <- lift $ desugarCases members
94 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
115 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
@@ -107,9 +128,15 @@ identToProperty :: Ident -> String
107identToProperty (Ident name) = name
128identToProperty (Ident name) = name
108identToProperty (Op op) = op
129identToProperty (Op op) = op
109
130
110−typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
131+typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
111−typeClassDictionaryDeclaration name args members =
132+typeClassDictionaryDeclaration name args implies members =
133+ let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)
134+ | (index, (superclass, tyArgs)) <- zip [0..] implies
135+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
136+ , let fieldName = mkSuperclassDictionaryName superclass index
137+ ], REmpty))
138+
112− TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))
139+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))
113
140
114typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
141typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
115typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
142typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
@@ -120,13 +147,21 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
120 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
147 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
121typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
148typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
122
149
150+mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
151+mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index
152+
153+unit :: Type
154+unit = TypeApp tyObject REmpty
155+
123typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
156typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
124typeInstanceDictionaryDeclaration name mn deps className tys decls = do
157typeInstanceDictionaryDeclaration name mn deps className tys decls = do
125 m <- get
158 m <- get
126
159
127 -- Lookup the type arguments and member types for the type class
160 -- Lookup the type arguments and member types for the type class
161+ (TypeClassDeclaration _ args implies tyDecls) <- lift $
128− (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right
162+ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
129− $ M.lookup (qualify mn className) m
163+ M.lookup (qualify mn className) m
164+ let instanceTys = map memberToNameAndType tyDecls
130
165
131 -- Replace the type arguments with the appropriate types in the member types
166 -- Replace the type arguments with the appropriate types in the member types
132 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
167 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
@@ -137,13 +172,19 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
137 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
172 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
138 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
173 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
139 -- dependencies, we introduce an unnamed function parameter.
174 -- dependencies, we introduce an unnamed function parameter.
140− let dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty))
175+ let superclasses = ObjectLiteral
176+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
177+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
178+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
179+ , let fieldName = mkSuperclassDictionaryName superclass index
180+ ]
181+
182+ let memberNames' = (C.__superclasses, superclasses) : memberNames
183+ dictTy = foldl TypeApp (TypeConstructor className) tys
141 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
184 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
142− dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames) else ObjectLiteral memberNames
185+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
143 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
186 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
144 where
187 where
145− unit :: Type
146− unit = TypeApp tyObject REmpty
147
188
148 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
189 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
149 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
190 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
src/Language/PureScript/TypeChecker.hs+5−5
@@ -73,10 +73,10 @@ addValue moduleName name ty nameKind = do
73 env <- getEnv
73 env <- getEnv
74 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })
74 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })
75
75
76−addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()
76+addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
77−addTypeClass moduleName pn args ds =
77+addTypeClass moduleName pn args implies ds =
78 let members = map toPair ds in
78 let members = map toPair ds in
79− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }
79+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
80 where
80 where
81 toPair (TypeDeclaration ident ty) = (ident, ty)
81 toPair (TypeDeclaration ident ty) = (ident, ty)
82 toPair (PositionedDeclaration _ d) = toPair d
82 toPair (PositionedDeclaration _ d) = toPair d
@@ -190,8 +190,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _)
190 ]
190 ]
191 ds <- typeCheckAll mainModuleName currentModule rest
191 ds <- typeCheckAll mainModuleName currentModule rest
192 return $ d : ds
192 return $ d : ds
193−typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do
193+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do
194− addTypeClass moduleName pn args tys
194+ addTypeClass moduleName pn args implies tys
195 ds <- typeCheckAll mainModuleName moduleName rest
195 ds <- typeCheckAll mainModuleName moduleName rest
196 return $ d : ds
196 return $ d : ds
197typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
197typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
src/Language/PureScript/TypeChecker/Types.hs+106−23
@@ -116,7 +116,7 @@ unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintT
116 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
116 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
117 t3 `unifyTypes` t5
117 t3 `unifyTypes` t5
118 t4 `unifyTypes` t6
118 t4 `unifyTypes` t6
119− unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()
119+ unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()
120 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
120 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
121 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
121 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
122 unifyTypes' r1@REmpty r2 = unifyRows r1 r2
122 unifyTypes' r1@REmpty r2 = unifyRows r1 r2
@@ -155,7 +155,7 @@ unifyRows r1 r2 =
155 unifyRows' row r others u'
155 unifyRows' row r others u'
156 unifyRows' [] REmpty [] REmpty = return ()
156 unifyRows' [] REmpty [] REmpty = return ()
157 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
157 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
158− unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
158+ unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
159 unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
159 unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
160
160
161-- |
161-- |
@@ -261,9 +261,9 @@ overTypes f = everywhere (mkT f)
261replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
261replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
262replaceTypeClassDictionaries mn = everywhereM' (mkM go)
262replaceTypeClassDictionaries mn = everywhereM' (mkM go)
263 where
263 where
264− go (TypeClassDictionary constraint dicts) = do
264+ go (TypeClassDictionary trySuperclasses constraint dicts) = do
265 env <- getEnv
265 env <- getEnv
266− entails env mn dicts constraint
266+ entails env mn dicts constraint trySuperclasses
267 go other = return other
267 go other = return other
268
268
269-- |
269-- |
@@ -283,13 +283,17 @@ data DictionaryValue
283 -- A dictionary which depends on other dictionaries
283 -- A dictionary which depends on other dictionaries
284 --
284 --
285 | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
285 | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
286+ -- |
287+ -- A subclass dictionary
288+ --
289+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
286 deriving (Show, Ord, Eq)
290 deriving (Show, Ord, Eq)
287
291
288-- |
292-- |
289-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
293-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
290-- return a type class dictionary reference.
294-- return a type class dictionary reference.
291--
295--
292−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
296+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value
293entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
297entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
294 where
298 where
295 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
299 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
@@ -301,13 +305,16 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
301 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
305 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
302 filterModule _ = False
306 filterModule _ = False
303
307
304− solve context' goal@(className, tys) =
308+ solve context' (className, tys) trySuperclasses =
305− case go goal of
309+ let
310+ dicts = go trySuperclasses className tys
311+ in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of
306− [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
312+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
307− [dict] -> return (dictionaryValueToValue dict)
313+ [_] -> return $ dictionaryValueToValue $ head dicts
308− _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
314+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
309 where
315 where
310− go (className', tys') =
316+ go trySuperclasses' className' tys' =
317+ -- Look for regular type instances
311 [ mkDictionary (canonicalizeDictionary tcd) args
318 [ mkDictionary (canonicalizeDictionary tcd) args
312 | tcd <- context'
319 | tcd <- context'
313 -- Make sure the type class name matches the one we are trying to satisfy
320 -- Make sure the type class name matches the one we are trying to satisfy
@@ -315,14 +322,29 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
315 -- Make sure the type unifies with the type in the type instance definition
322 -- Make sure the type unifies with the type in the type instance definition
316 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
323 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
317 -- Solve any necessary subgoals
324 -- Solve any necessary subgoals
318− , args <- solveSubgoals subst (tcdDependencies tcd) ]
325+ , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
326+
327+ -- Look for implementations via superclasses
328+ [ SubclassDictionaryValue suDict superclass index
329+ | trySuperclasses'
330+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
331+ -- Try each superclass
332+ , (index, (superclass, suTyArgs)) <- zip [0..] implies
333+ -- Make sure the type class name matches the superclass name
334+ , className' == superclass
335+ -- Make sure the types unify with the types in the superclass implication
336+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
337+ -- Finally, satisfy the subclass constraint
338+ , args' <- maybeToList $ mapM (applySubst subst . TypeVar) args
339+ , suDict <- go True subclassName args' ]
340+
319 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
341 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
320 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
342 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
321 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
343 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
322 solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
344 solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
323 solveSubgoals _ Nothing = return Nothing
345 solveSubgoals _ Nothing = return Nothing
324 solveSubgoals subst (Just subgoals) = do
346 solveSubgoals subst (Just subgoals) = do
325− dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals
347+ dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
326 return $ Just dict
348 return $ Just dict
327 -- Make a dictionary from subgoal dictionaries by applying the correct function
349 -- Make a dictionary from subgoal dictionaries by applying the correct function
328 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
350 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
@@ -334,12 +356,45 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
334 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
356 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
335 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
357 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
336 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
358 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
359+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
360+ App (Accessor (show superclassName ++ "_" ++ show index)
361+ (Accessor C.__superclasses (dictionaryValueToValue dict)))
362+ (ObjectLiteral [])
337 -- Ensure that a substitution is valid
363 -- Ensure that a substitution is valid
338 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
364 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
339 verifySubstitution subst = do
365 verifySubstitution subst = do
340 let grps = groupBy ((==) `on` fst) subst
366 let grps = groupBy ((==) `on` fst) subst
341 guard (all (pairwise (unifiesWith env) . map snd) grps)
367 guard (all (pairwise (unifiesWith env) . map snd) grps)
342 return $ map head grps
368 return $ map head grps
369+ -- Apply a substitution to a type
370+ applySubst :: [(String, Type)] -> Type -> Maybe Type
371+ applySubst subst = everywhereM (mkM replace)
372+ where
373+ replace (TypeVar v) = lookup v subst
374+ replace other = Just other
375+ -- Choose the simplest DictionaryValues from a list of candidates
376+ -- The reason for this function is as follows:
377+ -- When considering overlapping instances, we don't want to consider the same dictionary
378+ -- to be an overlap of itself when obtained as a superclass of another class.
379+ -- Observing that we probably don't want to select a superclass instance when an instance
380+ -- is available directly, and that there is no way for a superclass instance to actually
381+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
382+ -- obtained as superclass instances if there are simpler instances available.
383+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
384+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
385+ [] -> ds
386+ simple -> simple
387+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
388+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
389+ isSimpleDictionaryValue _ = True
390+ -- |
391+ -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
392+ -- data constructors
393+ --
394+ dictTrace :: DictionaryValue -> DictionaryValue
395+ dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
396+ dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
397+ dictTrace other = other
343
398
344-- |
399-- |
345-- Check all values in a list pairwise match a predicate
400-- Check all values in a list pairwise match a predicate
@@ -355,7 +410,7 @@ pairwise p (x : xs) = all (p x) xs && pairwise p xs
355unifiesWith :: Environment -> Type -> Type -> Bool
410unifiesWith :: Environment -> Type -> Type -> Bool
356unifiesWith _ (TUnknown _) _ = True
411unifiesWith _ (TUnknown _) _ = True
357unifiesWith _ _ (TUnknown _) = True
412unifiesWith _ _ (TUnknown _) = True
358−unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True
413+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
359unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
414unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
360unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
415unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
361unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
416unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
@@ -371,7 +426,7 @@ unifiesWith _ _ _ = False
371-- and return a substitution from type variables to types which makes the type heads unify.
426-- and return a substitution from type variables to types which makes the type heads unify.
372--
427--
373typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
428typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
374−typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
429+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
375typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
430typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
376typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
431typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
377typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
432typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
@@ -405,7 +460,7 @@ skolemEscapeCheck root@TypedValue{} =
405 collectSkolems :: Type -> [SkolemScope]
460 collectSkolems :: Type -> [SkolemScope]
406 collectSkolems = nub . everything (++) (mkQ [] collect)
461 collectSkolems = nub . everything (++) (mkQ [] collect)
407 where
462 where
408− collect (Skolem _ scope) = [scope]
463+ collect (Skolem _ _ scope) = [scope]
409 collect _ = []
464 collect _ = []
410 go _ scos = ([], scos)
465 go _ scos = ([], scos)
411 findBindingScope :: SkolemScope -> Maybe Value
466 findBindingScope :: SkolemScope -> Maybe Value
@@ -454,7 +509,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
454instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
509instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
455 dicts <- getTypeClassDictionaries
510 dicts <- getTypeClassDictionaries
456 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
511 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
457− return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
512+ return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')
458instantiatePolyTypeWithUnknowns val ty = return (val, ty)
513instantiatePolyTypeWithUnknowns val ty = return (val, ty)
459
514
460-- |
515-- |
@@ -578,7 +633,7 @@ infer' (Var var) = do
578 case ty of
633 case ty of
579 ConstrainedType constraints ty' -> do
634 ConstrainedType constraints ty' -> do
580 dicts <- getTypeClassDictionaries
635 dicts <- getTypeClassDictionaries
581− return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
636+ return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'
582 _ -> return $ TypedValue True (Var var) ty
637 _ -> return $ TypedValue True (Var var) ty
583infer' v@(Constructor c) = do
638infer' v@(Constructor c) = do
584 env <- getEnv
639 env <- getEnv
@@ -600,6 +655,9 @@ infer' (IfThenElse cond th el) = do
600infer' (Let ds val) = do
655infer' (Let ds val) = do
601 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
656 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
602 return $ TypedValue True (Let ds' val') valTy
657 return $ TypedValue True (Let ds' val') valTy
658+infer' (SuperClassDictionary className tys) = do
659+ dicts <- getTypeClassDictionaries
660+ return $ TypeClassDictionary False (className, tys) dicts
603infer' (TypedValue checkType val ty) = do
661infer' (TypedValue checkType val ty) = do
604 Just moduleName <- checkCurrentModule <$> get
662 Just moduleName <- checkCurrentModule <$> get
605 kind <- liftCheck $ kindOf moduleName ty
663 kind <- liftCheck $ kindOf moduleName ty
@@ -735,7 +793,18 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'
735-- Skolemize a type variable by replacing its instances with fresh skolem constants
793-- Skolemize a type variable by replacing its instances with fresh skolem constants
736--
794--
737skolemize :: String -> Int -> SkolemScope -> Type -> Type
795skolemize :: String -> Int -> SkolemScope -> Type -> Type
738−skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)
796+skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
797+
798+-- |
799+-- This function has one purpose - to skolemize type variables appearing in a
800+-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
801+-- only example of scoped type variables.
802+--
803+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value
804+skolemizeTypesInValue ident sko scope = everywhere (mkT go)
805+ where
806+ go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
807+ go other = other
739
808
740-- |
809-- |
741-- Introduce skolem scope at every occurence of a ForAll
810-- Introduce skolem scope at every occurence of a ForAll
@@ -766,7 +835,8 @@ check' val (ForAll ident ty _) = do
766 scope <- newSkolemScope
835 scope <- newSkolemScope
767 sko <- newSkolemConstant
836 sko <- newSkolemConstant
768 let sk = skolemize ident sko scope ty
837 let sk = skolemize ident sko scope ty
838+ let skVal = skolemizeTypesInValue ident sko scope val
769− val' <- check val sk
839+ val' <- check skVal sk
770 return $ TypedValue True val' (ForAll ident ty (Just scope))
840 return $ TypedValue True val' (ForAll ident ty (Just scope))
771check' val t@(ConstrainedType constraints ty) = do
841check' val t@(ConstrainedType constraints ty) = do
772 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
842 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
@@ -812,6 +882,19 @@ check' v@(Var var) ty = do
812 case v' of
882 case v' of
813 Nothing -> throwError . strMsg $ "Unable to check type subsumption"
883 Nothing -> throwError . strMsg $ "Unable to check type subsumption"
814 Just v'' -> return $ TypedValue True v'' ty'
884 Just v'' -> return $ TypedValue True v'' ty'
885+check' (SuperClassDictionary className tys) _ = do
886+ -- |
887+ -- Here, we replace a placeholder for a superclass dictionary with a regular
888+ -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
889+ -- correct super instance dictionaries in scope, and these are not available when the type class
890+ -- declaration gets desugared.
891+ --
892+ -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want
893+ -- to consider superclass instances when searching for this dictionary - doing so might lead
894+ -- to traversing a cycle in the instance graph.
895+ --
896+ dicts <- getTypeClassDictionaries
897+ return $ TypeClassDictionary False (className, tys) dicts
815check' (TypedValue checkType val ty1) ty2 = do
898check' (TypedValue checkType val ty1) ty2 = do
816 Just moduleName <- checkCurrentModule <$> get
899 Just moduleName <- checkCurrentModule <$> get
817 kind <- liftCheck $ kindOf moduleName ty1
900 kind <- liftCheck $ kindOf moduleName ty1
@@ -883,7 +966,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
883 go [] [] REmpty = return []
966 go [] [] REmpty = return []
884 go [] [] u@(TUnknown _) = do u =?= REmpty
967 go [] [] u@(TUnknown _) = do u =?= REmpty
885 return []
968 return []
886− go [] [] (Skolem _ _) | lax = return []
969+ go [] [] (Skolem _ _ _) | lax = return []
887 go [] ((p, _): _) _ | lax = return []
970 go [] ((p, _): _) _ | lax = return []
888 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
971 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
889 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
972 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
@@ -944,7 +1027,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
944 checkFunctionApplication fn ty arg ret
1027 checkFunctionApplication fn ty arg ret
945checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
1028checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
946 dicts <- getTypeClassDictionaries
1029 dicts <- getTypeClassDictionaries
947− checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
1030+ checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
948checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
1031checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
949 ++ prettyPrintType fnTy
1032 ++ prettyPrintType fnTy
950 ++ " to argument " ++ prettyPrintValue arg
1033 ++ " to argument " ++ prettyPrintValue arg
@@ -987,7 +1070,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
987subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
1070subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
988 dicts <- getTypeClassDictionaries
1071 dicts <- getTypeClassDictionaries
989 _ <- subsumes' Nothing ty1 ty2
1072 _ <- subsumes' Nothing ty1 ty2
990− return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)
1073+ return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)
991subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
1074subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
992 let
1075 let
993 (ts1, r1') = rowToList r1
1076 (ts1, r1') = rowToList r1
src/Language/PureScript/Types.hs+1−1
@@ -66,7 +66,7 @@ data Type
66 -- |
66 -- |
67 -- A skolem constant
67 -- A skolem constant
68 --
68 --
69− | Skolem Int SkolemScope
69+ | Skolem String Int SkolemScope
70 -- |
70 -- |
71 -- An empty row
71 -- An empty row
72 --
72 --