8ab522f · rowtype-yoga/purescript-native

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

Merge pull request #1431 from purescript/1426

Partial fix for 1426

commit8ab522f4243faa03b383c51e21b0300381e2d8e4 authorPhil Freeman <paf31@cantab.net> dateWed 26 Aug 2015, 10:28 (11 years ago) parentdaf6127 15ba03e

5 files changed+16−11

compare with golang

unifiedsplit

examples/failing/OverlappingInstances.purs → examples/passing/OverlappingInstances.purs+2−3 examples/failing/OverlappingInstances2.purs → examples/passing/OverlappingInstances2.purs+2−3 examples/failing/Superclasses4.purs → examples/passing/OverlappingInstances3.purs+3−2 src/Language/PureScript/Errors.hs+3−2 src/Language/PureScript/TypeChecker/Entailment.hs+6−1

examples/failing/OverlappingInstances.purs → examples/passing/OverlappingInstances.pursrenamed+2−3

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

1−-- @shouldFailWith OverlappingInstances

2−module OverlappingInstances where

1+module Main where

43import Prelude

@@ -11,4 +10,4 @@ instance showA1 :: Show A where

1110instance showA2 :: Show A where

1211 show A = "Instance 2"

1312

14−main = Control.Monad.Eff.Console.log $ show A

13+main = Test.Assert.assert $ show A == "Instance 1"

examples/failing/OverlappingInstances2.purs → examples/passing/OverlappingInstances2.pursrenamed+2−3

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

1−-- @shouldFailWith OverlappingInstances

2−module OverlappingInstances where

1+module Main where

43import Prelude

@@ -21,4 +20,4 @@ instance ordA :: Ord A where

2120test :: forall a. (Ord a) => a -> a -> String

2221test x y = show $ x == y

2322

24−main = Control.Monad.Eff.Console.log $ test A B

23+main = Test.Assert.assert $ test A B == "false"

examples/failing/Superclasses4.purs → examples/passing/OverlappingInstances3.pursrenamed+3−2

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

1−-- @shouldFailWith OverlappingInstances

2−module OverlappingInstances where

1+module Main where

43import Prelude

@@ -13,3 +12,5 @@ test :: forall a. (Foo a) => a -> a

1312test a = a

1413

1514test1 = test 0.0

15+

16+main = Test.Assert.assert (test1 == 0.0)

src/Language/PureScript/Errors.hs+3−2

@@ -558,10 +558,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

558558 , line "with type"

559559 , indent $ line $ prettyPrintType t2

560560 ]

561− goSimple (OverlappingInstances nm ts ds) =

561+ goSimple (OverlappingInstances nm ts (d : ds)) =

562562 paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"

563− , line $ intercalate ", " (map show ds)

563+ , indent $ paras (line (show d ++ " (chosen)") : map (line . show) ds)

564564 ]

565+ goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"

565566 goSimple (NoInstanceFound nm ts) =

566567 line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

567568 goSimple (PossiblyInfiniteInstance nm ts) =

src/Language/PureScript/TypeChecker/Entailment.hs+6−1

@@ -34,6 +34,7 @@ import Control.Applicative

3434import Control.Arrow (Arrow(..))

3535import Control.Monad.State

3636import Control.Monad.Error.Class (MonadError(..))

37+import Control.Monad.Writer.Class (tell)

3738

3839import Language.PureScript.AST

3940import Language.PureScript.Errors

@@ -83,7 +84,9 @@ entails env moduleName context = solve

8384 unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope)

8485 unique [] = throwError . errorMessage $ NoInstanceFound className' tys'

8586 unique [a] = return a

86− unique tcds | pairwise overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

87+ unique tcds | pairwise overlapping (map snd tcds) = do

88+ tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

89+ return (head tcds)

8790 | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds)

8891

8992 -- |

@@ -94,6 +97,8 @@ entails env moduleName context = solve

9497 overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool

9598 overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False

9699 overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False

100+ overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

101+ overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

97102 overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2

98103

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