ba585dc · rowtype-yoga/purescript-native

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

on golang help sign in

Add error for deep recursion in instance search, fix tests

ba585dcPhil Freeman11 years ago

src/Language/PureScript/Errors.hs+6−16

compare with golang

unifiedsplit

@@ -40,7 +40,6 @@ import Language.PureScript.Pretty

40import Language.PureScript.Types

41import Language.PureScript.Names

42import Language.PureScript.Kinds

43−import Language.PureScript.TypeClassDictionaries

45import qualified Text.PrettyPrint.Boxes as Box

44import qualified Text.PrettyPrint.Boxes as Box

@@ -108,8 +107,9 @@ data SimpleErrorMessage

108 | TypesDoNotUnify Type Type

107 | TypesDoNotUnify Type Type

109 | KindsDoNotUnify Kind Kind

108 | KindsDoNotUnify Kind Kind

110 | ConstrainedTypeUnified Type Type

109 | ConstrainedTypeUnified Type Type

111− | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]

110+ | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]

112 | NoInstanceFound (Qualified ProperName) [Type]

111 | NoInstanceFound (Qualified ProperName) [Type]

112+ | PossiblyInfiniteInstance (Qualified ProperName) [Type]

113 | CannotDerive (Qualified ProperName) [Type]

114 | CannotFindDerivingType ProperName

115 | DuplicateLabel String (Maybe Expr)

@@ -233,6 +233,7 @@ errorCode em = case unwrapErrorMessage em of

233 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

234 OverlappingInstances{} -> "OverlappingInstances"

235 NoInstanceFound{} -> "NoInstanceFound"

236+ PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"

236 CannotDerive{} -> "CannotDerive"

237 CannotDerive{} -> "CannotDerive"

237 CannotFindDerivingType{} -> "CannotFindDerivingType"

238 CannotFindDerivingType{} -> "CannotFindDerivingType"

238 DuplicateLabel{} -> "DuplicateLabel"

239 DuplicateLabel{} -> "DuplicateLabel"

@@ -544,10 +545,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

544 ]

545 ]

545 goSimple (OverlappingInstances nm ts ds) =

546 goSimple (OverlappingInstances nm ts ds) =

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

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

547− , paras $ map prettyPrintDictionaryValue ds

548+ , line $ intercalate ", " (map show ds)

548 ]

549 ]

549 goSimple (NoInstanceFound nm ts) =

550 goSimple (NoInstanceFound nm ts) =

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

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

552+ goSimple (PossiblyInfiniteInstance nm ts) =

553+ line $ "Instance for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."

551 goSimple (CannotDerive nm ts) =

554 goSimple (CannotDerive nm ts) =

552 line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)

555 line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)

553 goSimple (CannotFindDerivingType nm) =

556 goSimple (CannotFindDerivingType nm) =

@@ -736,19 +739,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

736 indent :: Box.Box -> Box.Box

739 indent :: Box.Box -> Box.Box

737 indent = Box.moveRight 2

740 indent = Box.moveRight 2

738

741

739− -- |

740− -- Render a DictionaryValue fit for human consumption in error messages

741− --

742− prettyPrintDictionaryValue :: DictionaryValue -> Box.Box

743− prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"

744− prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)

745− prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"

746− , indent $ paras $ map prettyPrintDictionaryValue args

747− ]

748− prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"

749− , indent $ prettyPrintDictionaryValue sup

750− ]

751−

752 -- |

742 -- |

753 -- Pretty print and export declaration

743 -- Pretty print and export declaration

754 --

744 --

src/Language/PureScript/TypeChecker/Entailment.hs+2−2

@@ -60,7 +60,7 @@ entails env moduleName context = solve

60 return $ dictionaryValueToValue dict

61 where

62 go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue

63− go work _ _ | work > 1000 = error "Overworked!"

63+ go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

64 go work className' tys' = do

65 let instances = do

66 tcd <- forClassName className'

@@ -78,7 +78,7 @@ entails env moduleName context = solve

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

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

80 unique [a] = return a

81− unique xs@(x : _) | pairwise overlapping (map snd xs) = throwError . errorMessage $ OverlappingInstances className' tys' [] -- include overlaps in error, use simplest instance

81+ unique xs@(x : _) | pairwise overlapping (map snd xs) = throwError . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) xs) -- TODO: use simplest instance

82 | otherwise = return x

84 -- |

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

@@ -467,7 +467,7 @@ check' val t@(ConstrainedType constraints ty) = do

467 return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)

468

469 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

470− instantiateSuperclass args supArgs tys = traceShow (args, supArgs, tys) $ map (replaceAllTypeVars (zip args tys)) supArgs

470+ instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

471check' val (SaturatedTypeSynonym name args) = do

472 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

473 check val ty