@@ -171,15 +171,16 @@ simpleCase tc cover phase fc []
171171simpleCase tc cover phase fc cs
172172 = let proj = phase == RunTime
173173 pats = map (\ (avs, l, r) ->
174− (avs, rev phase (toPats tc l), (l, r))) cs
174+ (avs, toPats tc l, (l, r))) cs
175175 chkPats = mapM chkAccessible pats in
176176 case chkPats of
177177 OK pats ->
178178 let numargs = length (fst (head pats))
179179 ns = take numargs args
180+ (ns', ps') = order ns pats
180181 (tree, st) = runState
181− (match (rev phase ns) pats (defaultCase cover)) ([], numargs)
182− t = CaseDef ns (prune proj (depatt ns tree)) (fst st) in
182+ (match ns' ps' (defaultCase cover)) ([], numargs)
183+ t = CaseDef ns (prune proj (depatt ns' tree)) (fst st) in
183184 if proj then return (stripLambdas t) else return t
184185 Error err -> Error (At fc err)
185186 where args = map (\i -> MN i "e") [0..]
@@ -196,11 +197,6 @@ simpleCase tc cover phase fc cs
196197 acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n
197198 acc (_ : xs) n = acc xs n
198199
199−-- right to left gives more chance of discriminating on interesting arguments
200−-- rather than indices which are likely to be repeated.
201−-- rev CompileTime = id
202−rev _ = reverse
203−
204200data Pat = PCon Name Int [Pat]
205201 | PConst Const
206202 | PV Name
@@ -264,6 +260,32 @@ partition ms@(m : _)
264260 Cons cons : partition rest
265261partition xs = error $ "Partition " ++ show xs
266262
263+-- reorder the patterns so that the one with most distinct names
264+-- comes next. Take rightmost first, otherwise (i.e. pick value rather
265+-- than dependency)
266+
267+order :: [Name] -> [Clause] -> ([Name], [Clause])
268+order [] cs = ([], cs)
269+order ns [] = (ns, [])
270+order ns cs = let patnames = transpose (map (zip ns) (map fst cs))
271+ pats' = transpose (sortBy moreDistinct (reverse patnames)) in
272+ (getNOrder pats', zipWith rebuild pats' cs)
273+ where
274+ getNOrder [] = error $ "Failed order on " ++ show (ns, cs)
275+ getNOrder (c : _) = map fst c
276+
277+ rebuild patnames clause = (map snd patnames, snd clause)
278+
279+ moreDistinct xs ys = compare (numNames [] (map snd ys))
280+ (numNames [] (map snd xs))
281+
282+ numNames xs (PCon n _ _ : ps)
283+ | not (Left n `elem` xs) = numNames (Left n : xs) ps
284+ numNames xs (PConst c : ps)
285+ | not (Right c `elem` xs) = numNames (Right c : xs) ps
286+ numNames xs (_ : ps) = numNames xs ps
287+ numNames xs [] = length xs
288+
267289match :: [Name] -> [Clause] -> SC -- error case
268290 -> State CS SC
269291match [] (([], ret) : xs) err
@@ -273,8 +295,7 @@ match [] (([], ret) : xs) err
273295 Impossible -> return ImpossibleCase
274296 tm -> return $ STerm tm -- run out of arguments
275297match vs cs err = do let ps = partition cs
276− cs <- mixture vs ps err
277− return cs
298+ mixture vs ps err
278299
279300mixture :: [Name] -> [Partition] -> SC -> State CS SC
280301mixture vs [] err = return err