e7d1fac · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1473 from purescript/1469-2

e7d1facPhil Freeman11 years ago

examples/passing/LargeSumType.pursnew file+33

compare with golang

unifiedsplit

@@ -0,0 +1,33 @@

1+module Main where

3+data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z

5+explode A A = "A"

6+explode B B = "B"

7+explode C C = "C"

8+explode D D = "D"

9+explode E E = "E"

10+explode F F = "F"

11+explode G G = "G"

12+explode H H = "H"

13+explode I I = "I"

14+explode J J = "J"

15+explode K K = "K"

16+explode L L = "L"

17+explode M M = "M"

18+explode N N = "N"

19+explode O O = "O"

20+explode P P = "P"

21+explode Q Q = "Q"

22+explode R R = "R"

23+explode S S = "S"

24+explode T T = "T"

25+explode U U = "U"

26+explode V V = "V"

27+explode W W = "W"

28+explode X X = "X"

29+explode Y Y = "Y"

30+explode Z Z = "Z"

31+explode _ _ = ""

32+

33+main = Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/Errors.hs+6

@@ -145,6 +145,7 @@ data SimpleErrorMessage

145 | WildcardInferredType Type

146 | NotExhaustivePattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

148+ | IncompleteExhaustivityCheck

148 | ClassOperator ProperName Ident

149 | ClassOperator ProperName Ident

149 | MisleadingEmptyTypeImport ModuleName ProperName

150 | MisleadingEmptyTypeImport ModuleName ProperName

150 | ImportHidingModule ModuleName

151 | ImportHidingModule ModuleName

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

274 WildcardInferredType{} -> "WildcardInferredType"

275 WildcardInferredType{} -> "WildcardInferredType"

275 NotExhaustivePattern{} -> "NotExhaustivePattern"

276 NotExhaustivePattern{} -> "NotExhaustivePattern"

276 OverlappingPattern{} -> "OverlappingPattern"

277 OverlappingPattern{} -> "OverlappingPattern"

278+ IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

277 ClassOperator{} -> "ClassOperator"

279 ClassOperator{} -> "ClassOperator"

278 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

280 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

279 ImportHidingModule{} -> "ImportHidingModule"

281 ImportHidingModule{} -> "ImportHidingModule"

@@ -662,6 +664,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

662 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

664 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

663 ] ++

665 ] ++

664 [ line "..." | not b ]

666 [ line "..." | not b ]

667+ goSimple IncompleteExhaustivityCheck =

668+ paras [ line "An exhaustivity check was abandoned due to too many possible cases."

669+ , line "You may want to decomposing your data types into smaller types."

670+ ]

665 go (NotYetDefined names err) =

671 go (NotYetDefined names err) =

666 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

672 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

667 , indent $ go err

673 , indent $ go err

src/Language/PureScript/Linter/Exhaustive.hs+46−28

@@ -29,6 +29,9 @@ import qualified Data.Map as M

29import Data.Maybe (fromMaybe)

30import Data.List (foldl', sortBy, nub)

31import Data.Function (on)

32+#if __GLASGOW_HASKELL__ < 710

33+import Data.Traversable (sequenceA)

34+#endif

33import Control.Monad (unless)

36import Control.Monad (unless)

34import Control.Applicative

37import Control.Applicative

@@ -45,6 +48,14 @@ import Language.PureScript.Errors

46import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)

49import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)

51+-- | There are two modes of failure for the redudancy check:

52+--

53+-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.

54+-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

55+--

56+-- We want to warn the user in the first case.

57+data RedudancyError = Incomplete | Unknown

58+

48-- |

59-- |

49-- Qualifies a propername from a given qualified propername and a default module name

60-- Qualifies a propername from a given qualified propername and a default module name

50--

61--

@@ -59,20 +70,20 @@ qualifyName n defmn qn = Qualified (Just mn) n

59-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

70-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

60-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

71-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

61--

72--

62−getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]

73+getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

63getConstructors env defmn n = extractConstructors lnte

74getConstructors env defmn n = extractConstructors lnte

64 where

75 where

65 qpn :: Qualified ProperName

76 qpn :: Qualified ProperName

66 qpn = getConsDataName n

77 qpn = getConsDataName n

68− getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)

79+ getConsDataName :: Qualified ProperName -> Qualified ProperName

69 getConsDataName con = qualifyName nm defmn con

80 getConsDataName con = qualifyName nm defmn con

70 where

81 where

71 nm = case getConsInfo con of

82 nm = case getConsInfo con of

72 Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

83 Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

73 Just (_, pm, _, _) -> pm

84 Just (_, pm, _, _) -> pm

75− getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])

86+ getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])

76 getConsInfo con = M.lookup con dce

87 getConsInfo con = M.lookup con dce

77 where

88 where

78 dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

89 dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

@@ -103,27 +114,27 @@ genericMerge _ [] [] = []

103genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs

114genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs

104genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs

115genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs

105genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

116genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

106− | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr

117+ | s < s' = f s (Just b) Nothing : genericMerge f bs bsr

107− | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'

118+ | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'

108− | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'

119+ | otherwise = f s (Just b) (Just b') : genericMerge f bs bs'

109

120

110-- |

121-- |

111-- Find the uncovered set between two binders:

122-- Find the uncovered set between two binders:

112-- the first binder is the case we are trying to cover, the second one is the matching binder

123-- the first binder is the case we are trying to cover, the second one is the matching binder

113--

124--

114−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool)

125+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)

115−missingCasesSingle _ _ _ NullBinder = ([], Just True)

126+missingCasesSingle _ _ _ NullBinder = ([], return True)

116−missingCasesSingle _ _ _ (VarBinder _) = ([], Just True)

127+missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

117missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

128missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

118missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl

129missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl

119missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

130missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

120− (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True)

131+ (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)

121 where

132 where

122 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))

133 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))

123 $ getConstructors env mn con

134 $ getConstructors env mn con

124missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

135missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

125 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

136 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

126− | otherwise = ([cb], Just False)

137+ | otherwise = ([cb], return False)

127missingCasesSingle env mn NullBinder (ObjectBinder bs) =

138missingCasesSingle env mn NullBinder (ObjectBinder bs) =

128 (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

139 (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

129 where

140 where

@@ -146,12 +157,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

146 compBS e s b b' = (s, compB e b b')

157 compBS e s b b' = (s, compB e b b')

147

158

148 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

159 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

149−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True)

160+missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)

150missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

161missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

151− | bl == br = ([], Just True)

162+ | bl == br = ([], return True)

152− | otherwise = ([BooleanBinder bl], Just False)

163+ | otherwise = ([BooleanBinder bl], return False)

153missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

164missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

154−missingCasesSingle _ _ b _ = ([b], Nothing)

165+missingCasesSingle _ _ b _ = ([b], Left Unknown)

155

166

156-- |

167-- |

157-- Returns the uncovered set of binders

168-- Returns the uncovered set of binders

@@ -179,7 +190,7 @@ missingCasesSingle _ _ b _ = ([b], Nothing)

179-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

190-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

180-- (which ought to be available soon), or increase the complexity of the algorithm.

191-- (which ought to be available soon), or increase the complexity of the algorithm.

181--

192--

182−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool)

193+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

183missingCasesMultiple env mn = go

194missingCasesMultiple env mn = go

184 where

195 where

185 go [] [] = ([], pure True)

196 go [] [] = ([], pure True)

@@ -213,10 +224,10 @@ isExhaustiveGuard (Right _) = True

213-- |

224-- |

214-- Returns the uncovered set of case alternatives

225-- Returns the uncovered set of case alternatives

215--

226--

216−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)

227+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)

217missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

228missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

218

229

219−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)

230+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

220missingAlternative env mn ca uncovered

231missingAlternative env mn ca uncovered

221 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

232 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

222 | otherwise = ([uncovered], snd mcases)

233 | otherwise = ([uncovered], snd mcases)

@@ -232,24 +243,31 @@ missingAlternative env mn ca uncovered

232checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

243checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

233checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

244checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

234 where

245 where

235− step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))

246+ step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

236 step (uncovered, (nec, redundant)) ca =

247 step (uncovered, (nec, redundant)) ca =

237 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

248 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

249+ (missed', approx) = splitAt 10000 (concat missed)

238− cond = or <$> sequenceA pr

250+ cond = liftA2 (&&) (or <$> sequenceA pr) nec

239− in (concat missed, (liftA2 (&&) cond nec,

251+ in (missed', ( if null approx

252+ then cond

253+ else Left Incomplete

254+ , if either (const True) id cond

255+ then redundant

240− if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))

256+ else caseAlternativeBinders ca : redundant

241−#if __GLASGOW_HASKELL__ < 710

257+ )

242− where

258+ )

243− sequenceA = foldr (liftA2 (:)) (pure [])

244−#endif

245

259

246− makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()

260+ makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

247− makeResult (bss, (_, bss')) =

261+ makeResult (bss, (rr, bss')) =

248 do unless (null bss) tellExhaustive

262 do unless (null bss) tellExhaustive

249 unless (null bss') tellRedundant

263 unless (null bss') tellRedundant

264+ case rr of

265+ Left Incomplete -> tellIncomplete

266+ _ -> return ()

250 where

267 where

251 tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

268 tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

252 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

269 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

270+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

253

271

254-- |

272-- |

255-- Exhaustivity checking over a list of declarations

273-- Exhaustivity checking over a list of declarations