e62efe1 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge branch 'superclasses'

Conflicts: src/Language/PureScript/Parser/Declarations.hs src/Language/PureScript/TypeChecker.hs

commite62efe1a1e1e82384ad2a3bcfae9012043c3bc0e authorPhil Freeman <paf31@cantab.net> dateTue 8 Apr 2014, 12:58 (13 years ago) parenta9173ff d4efd88

31 files changed+468−119

compare with golang

unifiedsplit

docgen/Main.hs+7−4

@@ -92,7 +92,7 @@ isExported (Just exps) decl = any (matches decl) exps

9292 matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'

9393 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'

9494 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'

9696 matches (P.PositionedDeclaration _ d) r = d `matches` r

9797 matches _ _ = False

9898

@@ -124,8 +124,11 @@ renderDeclaration n _ (P.ExternDataDeclaration name kind) =

124124renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

125125 let typeName = P.runProperName name ++ " " ++ unwords args

126126 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty

127−renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do

128− atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"

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) ++ ") <= "

131+ atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"

129132 mapM_ (renderDeclaration (n + 2) exps) ds

130133renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

131134 let constraintsText = case constraints of

@@ -142,7 +145,7 @@ getName (P.ExternDeclaration _ ident _ _) = show ident

142145getName (P.DataDeclaration name _ _) = P.runProperName name

143146getName (P.ExternDataDeclaration name _) = P.runProperName name

144147getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

145−getName (P.TypeClassDeclaration name _ _) = P.runProperName name

148+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

146149getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

147150getName (P.PositionedDeclaration _ d) = getName d

148151getName _ = error "Invalid argument to getName"

examples/failing/Superclasses1.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+class Su a where

4+ su :: a -> a

6+class (Su a) <= Cl a where

7+ cl :: a -> a -> a

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

3+class (Foo a) <= Bar a

5+class (Bar a) <= Foo a

7+instance barString :: Bar String

9+instance fooString :: Foo String

examples/failing/Superclasses3.pursnew file+5

@@ -0,0 +1,5 @@

1+module UnknownSuperclassTypeVar where

3+class Foo a

5+class (Foo b) <= Bar a

examples/failing/Superclasses4.pursnew file+12

@@ -0,0 +1,12 @@

1+module OverlappingInstances where

3+class Foo a

5+instance foo1 :: Foo Number

7+instance foo2 :: Foo Number

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

88 (<$>) f Nothing = Nothing

99 (<$>) f (Just x) = Just (f x)

1010

11−instance applicativeMaybe :: Applicative Maybe where

12− pure = Just

11+instance applyMaybe :: Apply Maybe where

1312 (<*>) (Just f) (Just x) = Just (f x)

1413 (<*>) _ _ = Nothing

1514

16−instance monadMaybe :: Prelude.Monad Maybe where

17− return = Just

15+instance applicativeMaybe :: Applicative Maybe where

16+ pure = Just

17+

18+instance bindMaybe :: Bind Maybe where

1819 (>>=) Nothing _ = Nothing

1920 (>>=) (Just a) f = f a

2021

21−test1 = \_ -> do

22+instance monadMaybe :: Prelude.Monad Maybe

23+

24+test1 = \_ -> do

2225 Just "abc"

2326

2427test2 = \_ -> do

@@ -43,14 +46,14 @@ test5 mx my mz = do

4346 z <- mz

4447 Just (z + sum + 1)

4548

46−test6 mx = \_ -> do

47− let

49+test6 mx = \_ -> do

50+ let

4851 f :: forall a. Maybe a -> a

4952 f (Just x) = x

5053 Just (f mx)

5154

52−test8 = \_ -> do

53− Just (do

55+test8 = \_ -> do

56+ Just (do

5457 Just 1)

5558

5659test9 = \_ -> (+) <$> Just 1 <*> Just 2

examples/passing/EqOrd.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+data Pair a b = Pair a b

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

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)

1212

1313runState s (State f) = f s

1414

15−instance monadState :: Prelude.Monad (State s) where

16− return a = State $ \s -> Tuple s a

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

22+ pure a = State $ \s -> Tuple s a

23+

24+instance bindState :: Bind (State s) where

1725 (>>=) f g = State $ \s -> case runState s f of

1826 Tuple s1 a -> runState s1 (g a)

1927

28+instance monadState :: Monad (State s)

29+

2030instance monadStateState :: MonadState s (State s) where

2131 get = State (\s -> Tuple s s)

2232 put s = State (\_ -> Tuple s {})

examples/passing/Operators.purs+4−2

@@ -3,6 +3,7 @@ module Main where

33 import Control.Monad.Eff

44 import Debug.Trace

6+ bar :: String -> String -> String

67 bar = \s1 s2 -> s1 ++ s2

89 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n

@@ -25,9 +26,10 @@ module Main where

2526

2627 test6 = ((\x -> x) `k` 2) 3

2728

28− (<>) = \s1 s2 -> s1 ++ s2

29+ (<+>) :: String -> String -> String

30+ (<+>) = \s1 s2 -> s1 ++ s2

2931

30− test7 = "Hello" <> "World!"

32+ test7 = "Hello" <+> "World!"

3133

3234 (@@) :: forall a b. (a -> b) -> a -> b

3335 (@@) = \f x -> f x

examples/passing/Superclasses1.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+class Su a where

4+ su :: a -> a

6+class (Su a) <= Cl a where

7+ cl :: a -> a -> a

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

3+class Su a where

4+ su :: a -> a

6+class (Su [a]) <= Cl a where

7+ cl :: a -> a -> a

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

3+import Debug.Trace

5+import Control.Monad.Eff

7+class (Monad m) <= MonadWriter w m where

8+ tell :: w -> m {}

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

2121

2222test3 = \_ -> show (Data "testing")

2323

24−instance monadData :: Prelude.Monad Data where

25− return = Data

24+instance functorData :: Functor Data where

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

2634 (>>=) (Data a) f = f a

2735

36+instance monadData :: Monad Data

37+

2838data Maybe a = Nothing | Just a

2939

30−instance monadMaybe :: Prelude.Monad Maybe where

31− return = Just

40+instance functorMaybe :: Functor Maybe where

41+ (<$>) = liftM1

42+

43+instance applyMaybe :: Apply Maybe where

44+ (<*>) = ap

45+

46+instance applicativeMaybe :: Applicative Maybe where

47+ pure = Just

48+

49+instance bindMaybe :: Bind Maybe where

3250 (>>=) Nothing _ = Nothing

3351 (>>=) (Just a) f = f a

3452

53+instance monadMaybe :: Monad Maybe

54+

3555test4 :: forall a m. (Monad m) => a -> m Number

3656test4 = \_ -> return 1

3757

@@ -43,10 +63,20 @@ instance showArray :: (Prelude.Show a) => Prelude.Show [a] where

4363

4464test6 = \_ -> show ["testing"]

4565

46−instance monadFunction :: Prelude.Monad ((->) r) where

47− return a r = a

66+instance functorFunction :: Functor ((->) r) where

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

4876 (>>=) f g r = g (f r) r

4977

78+instance monadFunction :: Monad ((->) r)

79+

5080ask r = r

5181

5282runReader r f = f r

@@ -54,6 +84,6 @@ runReader r f = f r

5484test9 _ = runReader 0 $ do

5585 n <- ask

5686 return $ n + 1

57−

87+

5888main = Debug.Trace.trace (test7 "Done")

5989

prelude/prelude.purs+48−27

@@ -59,10 +59,12 @@ module Prelude where

5959

6060 infixl 4 <*>

6161

62− class Applicative f where

63− pure :: forall a. a -> f a

62+ class (Functor f) <= Apply f where

6463 (<*>) :: forall a b. f (a -> b) -> f a -> f b

6564

65+ class (Apply f) <= Applicative f where

66+ pure :: forall a. a -> f a

67+

6668 liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

6769 liftA1 f a = pure f <*> a

6870

@@ -74,10 +76,14 @@ module Prelude where

7476

7577 infixl 1 >>=

7678

77− class Monad m where

78− return :: forall a. a -> m a

79+ class (Apply m) <= Bind m where

7980 (>>=) :: forall a b. m a -> (a -> m b) -> m b

8081

82+ class (Applicative m, Bind m) <= Monad m

83+

84+ return :: forall m a. (Monad m) => a -> m a

85+ return = pure

86+

8187 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

8288 liftM1 f a = do

8389 a' <- a

@@ -199,7 +205,7 @@ module Prelude where

199205 show GT = "GT"

200206 show EQ = "EQ"

201207

202− class Ord a where

208+ class (Eq a) <= Ord a where

203209 compare :: a -> a -> Ordering

204210

205211 infixl 4 <

@@ -339,13 +345,25 @@ module Prelude where

339345 (||) = boolOr

340346 not = boolNot

341347

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+

342363 infixr 5 ++

343364

344− foreign import (++) "function $plus$plus(s1) {\

345− \ return function(s2) {\

346− \ return s1 + s2;\

347− \ };\

348− \}" :: String -> String -> String

365+ (++) :: forall s. (Semigroup s) => s -> s -> s

366+ (++) = (<>)

349367

350368module Data.Eq where

351369

@@ -362,19 +380,19 @@ module Control.Monad.Eff where

362380

363381 foreign import data Eff :: # ! -> * -> *

364382

365− foreign import retEff "function retEff(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) {\

373− \ return function() {\

374− \ return f(a())();\

375− \ };\

383+ foreign import returnE "function returnE(a) {\

384+ \ return function() {\

385+ \ return a;\

376386 \ };\

377− \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

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+ \ };\

395+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

378396

379397 type Pure a = forall e. Eff e a

380398

@@ -385,13 +403,16 @@ module Control.Monad.Eff where

385403 instance functorEff :: Functor (Eff e) where

386404 (<$>) = liftA1

387405

388− instance applicativeEff :: Applicative (Eff e) where

389− pure = return

406+ instance applyEff :: Apply (Eff e) where

390407 (<*>) = ap

391408

392− instance monadEff :: Monad (Eff e) where

393− return = retEff

394− (>>=) = bindEff

409+ instance applicativeEff :: Applicative (Eff e) where

410+ pure = returnE

411+

412+ instance bindEff :: Bind (Eff e) where

413+ (>>=) = bindE

414+

415+ instance monadEff :: Monad (Eff e)

395416

396417 foreign import untilE "function untilE(f) {\

397418 \ return function() {\

purescript.cabal+1−1

@@ -1,5 +1,5 @@

11name: purescript

2−version: 0.4.16

2+version: 0.4.17

33cabal-version: >=1.8

44build-type: Custom

55license: MIT

src/Language/PureScript/CodeGen/Externs.hs+4−2

@@ -77,10 +77,12 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

7777 exportToPs (TypeClassRef className) =

7878 case Qualified (Just moduleName) className `M.lookup` typeClasses env of

7979 Nothing -> error $ show className ++ " has no type class definition in exportToPs"

80− Just (args, members) -> do

81− tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]

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) ++ ") <= "

82+ tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]

8283 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

8384 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

85+

8486 exportToPs (TypeInstanceRef ident) = do

8587 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

8688 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

144144valueToJs _ m _ (Var ident) = varToJs m ident

145145valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

146146valueToJs 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"

148148valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

149149

150150-- |

src/Language/PureScript/Constants.hs+9

@@ -146,6 +146,9 @@ pokeSTArray = "pokeSTArray"

146146monadEffDictionary :: String

147147monadEffDictionary = "monadEff"

148148

149+bindEffDictionary :: String

150+bindEffDictionary = "bindEff"

151+

149152numNumber :: String

150153numNumber = "numNumber"

151154

@@ -167,6 +170,9 @@ bitsNumber = "bitsNumber"

167170boolLikeBoolean :: String

168171boolLikeBoolean = "boolLikeBoolean"

169172

173+semigroupString :: String

174+semigroupString = "semigroupString"

175+

170176-- Main module

171177

172178main :: String

@@ -177,6 +183,9 @@ main = "main"

177183_ps :: String

178184_ps = "_ps"

179185

186+__superclasses :: String

187+__superclasses = "__superclasses"

188+

180189-- Modules

181190

182191prim :: String

src/Language/PureScript/Declarations.hs+9−4

@@ -158,9 +158,9 @@ data Declaration

158158 --

159159 | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)

160160 -- |

161− -- A type class declaration (name, argument, member declarations)

161+ -- A type class declaration (name, argument, implies, member declarations)

162162 --

163− | TypeClassDeclaration ProperName [String] [Declaration]

163+ | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]

164164 -- |

165165 -- A type instance declaration (name, dependencies, class name, instance types, member

166166 -- declarations)

@@ -329,10 +329,15 @@ data Value

329329 -- |

330330 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

331331 -- 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

333334 -- instance type, and the type class dictionaries in scope.

334335 --

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]

336341 -- |

337342 -- A value with source position information

338343 --

src/Language/PureScript/Environment.hs+1−1

@@ -53,7 +53,7 @@ data Environment = Environment {

5353 -- |

5454 -- Type classes

5555 --

56− , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])

56+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])

5757 } deriving (Show)

5858

5959-- |

src/Language/PureScript/Optimizer.hs−1

@@ -66,7 +66,6 @@ optimize opts | optionsNoOptimizations opts = id

6666 , inlineOperator (C.$) $ \f x -> JSApp f [x]

6767 , inlineOperator (C.#) $ \x f -> JSApp f [x]

6868 , inlineOperator (C.!!) $ flip JSIndexer

69− , inlineOperator (C.++) $ JSBinary Add

7069 , inlineCommonOperators ])

7170

7271untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

src/Language/PureScript/Optimizer/Inliner.hs+2

@@ -110,6 +110,8 @@ inlineCommonOperators = applyAll

110110 , binary C.eqBoolean (C.==) EqualTo

111111 , binary C.eqBoolean (C./=) NotEqualTo

112112

113+ , binary C.semigroupString (C.++) Add

114+

113115 , binaryFunction C.bitsNumber C.shl ShiftLeft

114116 , binaryFunction C.bitsNumber C.shr ShiftRight

115117 , 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)

7474 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []

7575 convert other = other

7676 -- 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

7878 isBind _ = False

7979 -- 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

8181 isReturn _ = False

8282 -- Check if an expression represents the polymorphic >>= function

8383 isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

@@ -101,11 +101,11 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

101101 name == name' = True

102102 isEffFunc _ _ = False

103103 -- Check if an expression represents the Monad Eff dictionary

104− isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True

105− isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&

106− _ps == C._ps &&

107− prop == C.monadEffDictionary = True

108− isEffDict _ = False

104+ isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True

105+ isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&

106+ _ps == C._ps &&

107+ prop == name = True

108+ isEffDict _ _ = False

109109 -- Remove __do function applications which remain after desugaring

110110 undo :: JS -> JS

111111 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 <*>

144144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

145145parseTypeClassDeclaration = do

146146 reserved "class"

147+ implies <- P.option [] $ do

148+ indented

149+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

150+ reservedOp "<="

151+ return implies

147152 className <- indented *> properName

148153 idents <- P.many (indented *> identifier)

149154 members <- P.option [] . P.try $ do

150155 indented *> reserved "where"

151156 mark (P.many (same *> positioned parseTypeDeclaration))

152− return $ TypeClassDeclaration className idents members

157+ return $ TypeClassDeclaration className idents implies members

153158

154159parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

155160parseTypeInstanceDeclaration = do

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -39,7 +39,7 @@ typeLiterals = mkPattern match

3939 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

4040 match (TypeConstructor ctor) = Just $ show ctor

4141 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

4343 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

4444 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"

4545 match REmpty = Just "()"

src/Language/PureScript/Pretty/Values.hs+2−1

@@ -73,7 +73,8 @@ literals = mkPattern' match

7373 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

7474 , currentIndent

7575 ]

76− match (TypeClassDictionary _ _) = return "<<dict>>"

76+ match (TypeClassDictionary _ _ _) = return "<<dict>>"

77+ match (SuperClassDictionary _ _) = return "<<superclass dict>>"

7778 match (TypedValue _ val _) = prettyPrintValue' val

7879 match (PositionedValue _ val) = prettyPrintValue' val

7980 match _ = mzero

src/Language/PureScript/Sugar/Names.hs+7−5

@@ -185,6 +185,8 @@ renameInModule imports exports (Module mn decls exps) =

185185 go (TypeSynonymDeclaration name ps ty) =

186186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $

187187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

188+ go (TypeClassDeclaration className args implies ds) =

189+ TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds

188190 go (TypeInstanceDeclaration name cs cn ts ds) =

189191 TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds

190192 go (ExternInstanceDeclaration name cs cn ts) =

@@ -209,7 +211,7 @@ renameInModule imports exports (Module mn decls exps) =

209211 bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

210212 (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

211213 bindFunctionArgs pb other = return (pb, other)

212−

214+

213215 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)

214216 bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)

215217

@@ -245,7 +247,7 @@ renameInModule imports exports (Module mn decls exps) =

245247 updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)

246248 updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)

247249 updateType pos t = return (pos, t)

248−

250+

249251 updateType' :: Data d => d -> Either ErrorStack d

250252 updateType' = everywhereWithContextM' Nothing (mkS updateType)

251253

@@ -301,7 +303,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

301303

302304 -- Add a declaration from a module to the global export environment

303305 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment

304− addDecl mn env (TypeClassDeclaration tcn _ ds) = do

306+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do

305307 env' <- addTypeClass env mn tcn

306308 foldM go env' ds

307309 where

@@ -393,14 +395,14 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron

393395resolveImports env (Module currentModule decls _) =

394396 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

395397 where

396−

398+

397399 -- A Map from module name to the source position for the import, the list of imports from that

398400 -- module (where Nothing indicates everything is to be imported), and optionally a qualified name

399401 -- for the module

400402 scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

401403 scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)

402404

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

404406 resolveImport' imp (mn, (pos, explImports, impQual)) = do

405407 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

406408 positioned $ resolveImport currentModule mn modExports imp impQual explImports

src/Language/PureScript/Sugar/TypeClasses.hs+55−14

@@ -27,6 +27,8 @@ import Language.PureScript.Environment

2727import Language.PureScript.Errors

2828import Language.PureScript.CodeGen.Common (identToJs)

2929

30+import qualified Language.PureScript.Constants as C

31+

3032import Control.Applicative

3133import Control.Monad.State

3234import Control.Arrow (first, second)

@@ -34,7 +36,7 @@ import Data.Maybe (catMaybes)

3436

3537import qualified Data.Map as M

3638

37−type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])

39+type MemberMap = M.Map (ModuleName, ProperName) Declaration

3840

3941type Desugar = StateT MemberMap (Either ErrorStack)

4042

@@ -70,6 +72,14 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

7072-- instance fooArray :: (Foo a) => Foo [a] where

7173-- foo = map foo

7274--

75+-- {- Superclasses -}

76+--

77+-- class (Foo a) <= Sub a where

78+-- sub :: a

79+--

80+-- instance subString :: Sub String where

81+-- sub = ""

82+--

7383-- becomes

7484--

7585-- type Foo a = { foo :: a -> a }

@@ -84,11 +94,22 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

8494-- fooArray :: forall a. (Foo a) => Foo [a]

8595-- fooArray = { foo: map foo }

8696--

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+--

87109desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

88−desugarDecl mn d@(TypeClassDeclaration name args members) = do

89− let tys = map memberToNameAndType members

90− modify (M.insert (mn, name) (args, tys))

91− return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

110+desugarDecl mn d@(TypeClassDeclaration name args implies members) = do

111+ modify (M.insert (mn, name) d)

112+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

92113desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

93114 desugared <- lift $ desugarCases members

94115 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

@@ -107,9 +128,15 @@ identToProperty :: Ident -> String

107128identToProperty (Ident name) = name

108129identToProperty (Op op) = op

109130

110−typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

111−typeClassDictionaryDeclaration name args members =

112− TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))

131+typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

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+

139+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))

113140

114141typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

115142typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

@@ -120,13 +147,21 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

120147 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

121148typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

122149

150+mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String

151+mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index

152+

153+unit :: Type

154+unit = TypeApp tyObject REmpty

155+

123156typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

124157typeInstanceDictionaryDeclaration name mn deps className tys decls = do

125158 m <- get

126159

127160 -- Lookup the type arguments and member types for the type class

128− (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

129− $ M.lookup (qualify mn className) m

161+ (TypeClassDeclaration _ args implies tyDecls) <- lift $

162+ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $

163+ M.lookup (qualify mn className) m

164+ let instanceTys = map memberToNameAndType tyDecls

130165

131166 -- Replace the type arguments with the appropriate types in the member types

132167 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

@@ -137,13 +172,19 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

137172 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary

138173 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no

139174 -- 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

141184 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'

143186 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

144187 where

145− unit :: Type

146− unit = TypeApp tyObject REmpty

147188

148189 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

149190 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

src/Language/PureScript/TypeChecker.hs+5−5

@@ -73,10 +73,10 @@ addValue moduleName name ty nameKind = do

7373 env <- getEnv

7474 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })

7575

76−addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()

77−addTypeClass moduleName pn args ds =

76+addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

77+addTypeClass moduleName pn args implies ds =

7878 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) } }

8080 where

8181 toPair (TypeDeclaration ident ty) = (ident, ty)

8282 toPair (PositionedDeclaration _ d) = toPair d

@@ -190,8 +190,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _)

190190 ]

191191 ds <- typeCheckAll mainModuleName currentModule rest

192192 return $ d : ds

193−typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do

194− addTypeClass moduleName pn args tys

193+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do

194+ addTypeClass moduleName pn args implies tys

195195 ds <- typeCheckAll mainModuleName moduleName rest

196196 return $ d : ds

197197typeCheckAll 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

116116 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

117117 t3 `unifyTypes` t5

118118 t4 `unifyTypes` t6

119− unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()

119+ unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()

120120 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

121121 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

122122 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

@@ -155,7 +155,7 @@ unifyRows r1 r2 =

155155 unifyRows' row r others u'

156156 unifyRows' [] REmpty [] REmpty = return ()

157157 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 ()

159159 unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"

160160

161161-- |

@@ -261,9 +261,9 @@ overTypes f = everywhere (mkT f)

261261replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

262262replaceTypeClassDictionaries mn = everywhereM' (mkM go)

263263 where

264− go (TypeClassDictionary constraint dicts) = do

264+ go (TypeClassDictionary trySuperclasses constraint dicts) = do

265265 env <- getEnv

266− entails env mn dicts constraint

266+ entails env mn dicts constraint trySuperclasses

267267 go other = return other

268268

269269-- |

@@ -283,13 +283,17 @@ data DictionaryValue

283283 -- A dictionary which depends on other dictionaries

284284 --

285285 | DependentDictionaryValue (Qualified Ident) [DictionaryValue]

286+ -- |

287+ -- A subclass dictionary

288+ --

289+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

286290 deriving (Show, Ord, Eq)

287291

288292-- |

289293-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

290294-- return a type class dictionary reference.

291295--

292−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

296+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value

293297entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))

294298 where

295299 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]

@@ -301,13 +305,16 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

301305 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

302306 filterModule _ = False

303307

304− solve context' goal@(className, tys) =

305− case go goal of

306− [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

307− [dict] -> return (dictionaryValueToValue dict)

308− _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

308+ solve context' (className, tys) trySuperclasses =

309+ let

310+ dicts = go trySuperclasses className tys

311+ in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of

312+ [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

313+ [_] -> return $ dictionaryValueToValue $ head dicts

314+ _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

309315 where

310− go (className', tys') =

316+ go trySuperclasses' className' tys' =

317+ -- Look for regular type instances

311318 [ mkDictionary (canonicalizeDictionary tcd) args

312319 | tcd <- context'

313320 -- 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

315322 -- Make sure the type unifies with the type in the type instance definition

316323 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

317324 -- 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+

319341 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

320342 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

321343 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

322344 solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]

323345 solveSubgoals _ Nothing = return Nothing

324346 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

326348 return $ Just dict

327349 -- Make a dictionary from subgoal dictionaries by applying the correct function

328350 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue

@@ -334,12 +356,45 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

334356 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

335357 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])

336358 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 [])

337363 -- Ensure that a substitution is valid

338364 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

339365 verifySubstitution subst = do

340366 let grps = groupBy ((==) `on` fst) subst

341367 guard (all (pairwise (unifiesWith env) . map snd) grps)

342368 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

343398

344399-- |

345400-- 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

355410unifiesWith :: Environment -> Type -> Type -> Bool

356411unifiesWith _ (TUnknown _) _ = True

357412unifiesWith _ _ (TUnknown _) = True

358−unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True

413+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True

359414unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True

360415unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

361416unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2

@@ -371,7 +426,7 @@ unifiesWith _ _ _ = False

371426-- and return a substitution from type variables to types which makes the type heads unify.

372427--

373428typeHeadsAreEqual :: 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 []

375430typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

376431typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

377432typeHeadsAreEqual 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{} =

405460 collectSkolems :: Type -> [SkolemScope]

406461 collectSkolems = nub . everything (++) (mkQ [] collect)

407462 where

408− collect (Skolem _ scope) = [scope]

463+ collect (Skolem _ _ scope) = [scope]

409464 collect _ = []

410465 go _ scos = ([], scos)

411466 findBindingScope :: SkolemScope -> Maybe Value

@@ -454,7 +509,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

454509instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

455510 dicts <- getTypeClassDictionaries

456511 (_, 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')

458513instantiatePolyTypeWithUnknowns val ty = return (val, ty)

459514

460515-- |

@@ -578,7 +633,7 @@ infer' (Var var) = do

578633 case ty of

579634 ConstrainedType constraints ty' -> do

580635 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'

582637 _ -> return $ TypedValue True (Var var) ty

583638infer' v@(Constructor c) = do

584639 env <- getEnv

@@ -600,6 +655,9 @@ infer' (IfThenElse cond th el) = do

600655infer' (Let ds val) = do

601656 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

602657 return $ TypedValue True (Let ds' val') valTy

658+infer' (SuperClassDictionary className tys) = do

659+ dicts <- getTypeClassDictionaries

660+ return $ TypeClassDictionary False (className, tys) dicts

603661infer' (TypedValue checkType val ty) = do

604662 Just moduleName <- checkCurrentModule <$> get

605663 kind <- liftCheck $ kindOf moduleName ty

@@ -735,7 +793,18 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'

735793-- Skolemize a type variable by replacing its instances with fresh skolem constants

736794--

737795skolemize :: 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

739808

740809-- |

741810-- Introduce skolem scope at every occurence of a ForAll

@@ -766,7 +835,8 @@ check' val (ForAll ident ty _) = do

766835 scope <- newSkolemScope

767836 sko <- newSkolemConstant

768837 let sk = skolemize ident sko scope ty

769− val' <- check val sk

838+ let skVal = skolemizeTypesInValue ident sko scope val

839+ val' <- check skVal sk

770840 return $ TypedValue True val' (ForAll ident ty (Just scope))

771841check' val t@(ConstrainedType constraints ty) = do

772842 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

@@ -812,6 +882,19 @@ check' v@(Var var) ty = do

812882 case v' of

813883 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

814884 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

815898check' (TypedValue checkType val ty1) ty2 = do

816899 Just moduleName <- checkCurrentModule <$> get

817900 kind <- liftCheck $ kindOf moduleName ty1

@@ -883,7 +966,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

883966 go [] [] REmpty = return []

884967 go [] [] u@(TUnknown _) = do u =?= REmpty

885968 return []

886− go [] [] (Skolem _ _) | lax = return []

969+ go [] [] (Skolem _ _ _) | lax = return []

887970 go [] ((p, _): _) _ | lax = return []

888971 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

889972 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

9441027 checkFunctionApplication fn ty arg ret

9451028checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

9461029 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

9481031checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

9491032 ++ prettyPrintType fnTy

9501033 ++ " to argument " ++ prettyPrintValue arg

@@ -987,7 +1070,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

9871070subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

9881071 dicts <- getTypeClassDictionaries

9891072 _ <- 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)

9911074subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do

9921075 let

9931076 (ts1, r1') = rowToList r1

src/Language/PureScript/Types.hs+1−1

@@ -66,7 +66,7 @@ data Type

6666 -- |

6767 -- A skolem constant

6868 --

69− | Skolem Int SkolemScope

69+ | Skolem String Int SkolemScope

7070 -- |

7171 -- An empty row

7272 --